libguile/continuations.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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 <assert.h>
  28 #include <string.h>
  29 #include <stdio.h>
  30
  31 #include "libguile/async.h"
  32 #include "libguile/debug.h"
  33 #include "libguile/root.h"
  34 #include "libguile/stackchk.h"
  35 #include "libguile/smob.h"
  36 #include "libguile/ports.h"
  37 #include "libguile/dynstack.h"
  38 #include "libguile/eval.h"
  39 #include "libguile/vm.h"
  40 #include "libguile/instructions.h"
  41
  42 #include "libguile/validate.h"
  43 #include "libguile/continuations.h"
  44
  45 \f
  46
  47 static scm_t_bits tc16_continuation;
  48 #define SCM_CONTREGSP(x)        SCM_TYP16_PREDICATE (tc16_continuation, x)
  49
  50 #define SCM_CONTREGS(x)         ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
  51
  52 #define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
  53 #define SCM_SET_CONTINUATION_LENGTH(x, n)\
  54    (SCM_CONTREGS (x)->num_stack_items = (n))
  55 #define SCM_JMPBUF(x)            ((SCM_CONTREGS (x))->jmpbuf)
  56 #define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
  57 #define SCM_DFRAME(x)            ((SCM_CONTREGS (x))->dframe)
  58
  59 \f
  60
  61 /* scm_i_make_continuation will return a procedure whose code will
  62    reinstate the continuation. Here, as in gsubr.c, we define the form
  63    of that trampoline function.
  64  */
  65
  66 static const scm_t_uint32 continuation_stub_code[] =
  67   {
  68     SCM_PACK_RTL_24 (scm_rtl_op_continuation_call, 0)
  69   };
  70
  71 /* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
  72    call/cc. */
  73
  74 static const scm_t_uint32 call_cc_code[] =
  75   {
  76     SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
  77     SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
  78   };
  79
  80 static SCM
  81 make_continuation_trampoline (SCM contregs)
  82 {
  83   SCM ret;
  84   scm_t_bits nfree = 1;
  85   scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
  86
  87   ret = scm_words (scm_tc7_rtl_program | (nfree << 16) | flags, nfree + 2);
  88   SCM_SET_CELL_WORD_1 (ret, continuation_stub_code);
  89   SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
  90
  91   return ret;
  92 }
  93
  94
  95 /* {Continuations}
  96  */
  97
  98
  99 static int
 100 continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
 101 {
 102   scm_t_contregs *continuation = SCM_CONTREGS (obj);
 103
 104   scm_puts_unlocked ("#<continuation ", port);
 105   scm_intprint (continuation->num_stack_items, 10, port);
 106   scm_puts_unlocked (" @ ", port);
 107   scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
 108   scm_putc_unlocked ('>', port);
 109   return 1;
 110 }
 111
 112 /* James Clark came up with this neat one instruction fix for
 113  * continuations on the SPARC.  It flushes the register windows so
 114  * that all the state of the process is contained in the stack.
 115  */
 116
 117 #if defined (sparc) || defined (__sparc__) || defined (__sparc)
 118 # define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
 119 #else
 120 # define SCM_FLUSH_REGISTER_WINDOWS /* empty */
 121 #endif
 122
 123 /* this may return more than once: the first time with the escape
 124    procedure, then subsequently with SCM_UNDEFINED (the vals already having been
 125    placed on the VM stack). */
 126 #define FUNC_NAME "scm_i_make_continuation"
 127 SCM
 128 scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
 129 {
 130   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 131   SCM cont;
 132   scm_t_contregs *continuation;
 133   long stack_size;
 134   SCM_STACKITEM * src;
 135
 136   SCM_FLUSH_REGISTER_WINDOWS;
 137   stack_size = scm_stack_size (thread->continuation_base);
 138   continuation = scm_gc_malloc (sizeof (scm_t_contregs)
 139                                 + (stack_size - 1) * sizeof (SCM_STACKITEM),
 140                                 "continuation");
 141   continuation->num_stack_items = stack_size;
 142   continuation->root = thread->continuation_root;
 143   src = thread->continuation_base;
 144 #if ! SCM_STACK_GROWS_UP
 145   src -= stack_size;
 146 #endif
 147   continuation->offset = continuation->stack - src;
 148   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 149   continuation->vm = vm;
 150   continuation->vm_cont = vm_cont;
 151
 152   SCM_NEWSMOB (cont, tc16_continuation, continuation);
 153
 154   *first = !SCM_I_SETJMP (continuation->jmpbuf);
 155   if (*first)
 156     {
 157 #ifdef __ia64__
 158       continuation->backing_store_size =
 159         (char *) scm_ia64_ar_bsp(&continuation->jmpbuf.ctx)
 160         -
 161         (char *) thread->register_backing_store_base;
 162       continuation->backing_store = NULL;
 163       continuation->backing_store =
 164         scm_gc_malloc (continuation->backing_store_size,
 165                        "continuation backing store");
 166       memcpy (continuation->backing_store,
 167               (void *) thread->register_backing_store_base,
 168               continuation->backing_store_size);
 169 #endif /* __ia64__ */
 170       return make_continuation_trampoline (cont);
 171     }
 172   else
 173     return SCM_UNDEFINED;
 174 }
 175 #undef FUNC_NAME
 176
 177 SCM
 178 scm_i_call_with_current_continuation (SCM proc)
 179 {
 180   static SCM call_cc = SCM_BOOL_F;
 181
 182   if (scm_is_false (call_cc))
 183     call_cc = scm_i_make_rtl_program (call_cc_code);
 184
 185   return scm_call_1 (call_cc, proc);
 186 }
 187
 188 SCM
 189 scm_i_continuation_to_frame (SCM continuation)
 190 {
 191   SCM contregs;
 192   scm_t_contregs *cont;
 193
 194   contregs = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
 195   cont = SCM_CONTREGS (contregs);
 196
 197   if (scm_is_true (cont->vm_cont))
 198     {
 199       struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
 200       return scm_c_make_frame (cont->vm_cont,
 201                                data->fp + data->reloc,
 202                                data->sp + data->reloc,
 203                                data->ra,
 204                                data->reloc);
 205     }
 206   else
 207     return SCM_BOOL_F;
 208 }
 209
 210 SCM
 211 scm_i_contregs_vm (SCM contregs)
 212 {
 213   return SCM_CONTREGS (contregs)->vm;
 214 }
 215
 216 SCM
 217 scm_i_contregs_vm_cont (SCM contregs)
 218 {
 219   return SCM_CONTREGS (contregs)->vm_cont;
 220 }
 221
 222
 223 /* {Apply}
 224  */
 225
 226 /* Invoking a continuation proceeds as follows:
 227  *
 228  * - the stack is made large enough for the called continuation
 229  * - the old windchain is unwound down to the branching point
 230  * - the continuation stack is copied into place
 231  * - the windchain is rewound up to the continuation's context
 232  * - the continuation is invoked via longjmp (or setcontext)
 233  *
 234  * This order is important so that unwind and rewind handlers are run
 235  * with their correct stack.
 236  */
 237
 238 static void scm_dynthrow (SCM);
 239
 240 /* Grow the stack by a fixed amount to provide space to copy in the
 241  * continuation.  Possibly this function has to be called several times
 242  * recursively before enough space is available.  Make sure the compiler does
 243  * not optimize the growth array away by storing it's address into a global
 244  * variable.
 245  */
 246
 247 static scm_t_bits scm_i_dummy;
 248
 249 static void
 250 grow_stack (SCM cont)
 251 {
 252   scm_t_bits growth[100];
 253
 254   scm_i_dummy = (scm_t_bits) growth;
 255   scm_dynthrow (cont);
 256 }
 257
 258
 259 /* Copy the continuation stack into the current stack.  Calling functions from
 260  * within this function is safe, since only stack frames below this function's
 261  * own frame are overwritten.  Thus, memcpy can be used for best performance.
 262  */
 263
 264 static void
 265 copy_stack_and_call (scm_t_contregs *continuation,
 266                      SCM_STACKITEM * dst)
 267 {
 268   scm_t_dynstack *dynstack;
 269   scm_t_bits *joint;
 270   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 271
 272   dynstack = SCM_VM_CONT_DATA (continuation->vm_cont)->dynstack;
 273
 274   joint = scm_dynstack_unwind_fork (&thread->dynstack, dynstack);
 275
 276   memcpy (dst, continuation->stack,
 277           sizeof (SCM_STACKITEM) * continuation->num_stack_items);
 278 #ifdef __ia64__
 279   thread->pending_rbs_continuation = continuation;
 280 #endif
 281
 282   scm_dynstack_wind (&thread->dynstack, joint);
 283
 284   SCM_I_LONGJMP (continuation->jmpbuf, 1);
 285 }
 286
 287 #ifdef __ia64__
 288 void
 289 scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
 290 {
 291   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 292
 293   if (t->pending_rbs_continuation)
 294     {
 295       memcpy (t->register_backing_store_base,
 296               t->pending_rbs_continuation->backing_store,
 297               t->pending_rbs_continuation->backing_store_size);
 298       t->pending_rbs_continuation = NULL;
 299     }
 300   setcontext (&JB->ctx);
 301 }
 302 #endif
 303
 304 /* Call grow_stack until the stack space is large enough, then, as the current
 305  * stack frame might get overwritten, let copy_stack_and_call perform the
 306  * actual copying and continuation calling.
 307  */
 308 static void
 309 scm_dynthrow (SCM cont)
 310 {
 311   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 312   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 313   SCM_STACKITEM *dst = thread->continuation_base;
 314   SCM_STACKITEM stack_top_element;
 315
 316   if (thread->critical_section_level)
 317     {
 318       fprintf (stderr, "continuation invoked from within critical section.\n");
 319       abort ();
 320     }
 321
 322 #if SCM_STACK_GROWS_UP
 323   if (dst + continuation->num_stack_items >= &stack_top_element)
 324     grow_stack (cont);
 325 #else
 326   dst -= continuation->num_stack_items;
 327   if (dst <= &stack_top_element)
 328     grow_stack (cont);
 329 #endif /* def SCM_STACK_GROWS_UP */
 330
 331   SCM_FLUSH_REGISTER_WINDOWS;
 332   copy_stack_and_call (continuation, dst);
 333 }
 334
 335
 336 void
 337 scm_i_check_continuation (SCM cont)
 338 {
 339   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 340   scm_t_contregs *continuation = SCM_CONTREGS (cont);
 341
 342   if (!scm_is_eq (continuation->root, thread->continuation_root))
 343     scm_misc_error
 344       ("%continuation-call",
 345        "invoking continuation would cross continuation barrier: ~A",
 346        scm_list_1 (cont));
 347 }
 348
 349 void
 350 scm_i_reinstate_continuation (SCM cont)
 351 {
 352   scm_dynthrow (cont);
 353 }
 354
 355 SCM
 356 scm_i_with_continuation_barrier (scm_t_catch_body body,
 357                                  void *body_data,
 358                                  scm_t_catch_handler handler,
 359                                  void *handler_data,
 360                                  scm_t_catch_handler pre_unwind_handler,
 361                                  void *pre_unwind_handler_data)
 362 {
 363   SCM_STACKITEM stack_item;
 364   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 365   SCM old_controot;
 366   SCM_STACKITEM *old_contbase;
 367   SCM result;
 368
 369   /* Establish a fresh continuation root.
 370    */
 371   old_controot = thread->continuation_root;
 372   old_contbase = thread->continuation_base;
 373   thread->continuation_root = scm_cons (thread->handle, old_controot);
 374   thread->continuation_base = &stack_item;
 375
 376   /* Call FUNC inside a catch all.  This is now guaranteed to return
 377      directly and exactly once.
 378   */
 379   result = scm_c_catch (SCM_BOOL_T,
 380                         body, body_data,
 381                         handler, handler_data,
 382                         pre_unwind_handler, pre_unwind_handler_data);
 383
 384   /* Return to old continuation root.
 385    */
 386   thread->continuation_base = old_contbase;
 387   thread->continuation_root = old_controot;
 388
 389   return result;
 390 }
 391
 392 \f
 393
 394 static int
 395 should_print_backtrace (SCM tag, SCM stack)
 396 {
 397   return SCM_BACKTRACE_P
 398     && scm_is_true (stack)
 399     && scm_initialized_p
 400     /* It's generally not useful to print backtraces for errors reading
 401        or expanding code in these fallback catch statements. */
 402     && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
 403     && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
 404 }
 405
 406 static void
 407 print_exception_and_backtrace (SCM port, SCM tag, SCM args)
 408 {
 409   SCM stack, frame;
 410
 411   /* We get here via a throw to a catch-all.  In that case there is the
 412      throw frame active, and this catch closure, so narrow by two
 413      frames.  */
 414   stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
 415   frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
 416
 417   if (should_print_backtrace (tag, stack))
 418     {
 419       scm_puts_unlocked ("Backtrace:\n", port);
 420       scm_display_backtrace_with_highlights (stack, port,
 421                                              SCM_BOOL_F, SCM_BOOL_F,
 422                                              SCM_EOL);
 423       scm_newline (port);
 424     }
 425
 426   scm_print_exception (port, frame, tag, args);
 427 }
 428
 429 \f
 430
 431 struct c_data {
 432   void *(*func) (void *);
 433   void *data;
 434   void *result;
 435 };
 436
 437 static SCM
 438 c_body (void *d)
 439 {
 440   struct c_data *data = (struct c_data *)d;
 441   data->result = data->func (data->data);
 442   return SCM_UNSPECIFIED;
 443 }
 444
 445 static SCM
 446 c_handler (void *d, SCM tag, SCM args)
 447 {
 448   struct c_data *data;
 449
 450   /* If TAG is `quit', exit() the process.  */
 451   if (scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
 452     exit (scm_exit_status (args));
 453
 454   data = (struct c_data *)d;
 455   data->result = NULL;
 456   return SCM_UNSPECIFIED;
 457 }
 458
 459 static SCM
 460 pre_unwind_handler (void *error_port, SCM tag, SCM args)
 461 {
 462   /* Print the exception unless TAG is  `quit'.  */
 463   if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
 464     print_exception_and_backtrace (SCM_PACK_POINTER (error_port), tag, args);
 465
 466   return SCM_UNSPECIFIED;
 467 }
 468
 469 void *
 470 scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
 471 {
 472   struct c_data c_data;
 473   c_data.func = func;
 474   c_data.data = data;
 475   scm_i_with_continuation_barrier (c_body, &c_data,
 476                                    c_handler, &c_data,
 477                                    pre_unwind_handler,
 478                                    SCM_UNPACK_POINTER (scm_current_error_port ()));
 479   return c_data.result;
 480 }
 481
 482 struct scm_data {
 483   SCM proc;
 484 };
 485
 486 static SCM
 487 scm_body (void *d)
 488 {
 489   struct scm_data *data = (struct scm_data *)d;
 490   return scm_call_0 (data->proc);
 491 }
 492
 493 static SCM
 494 scm_handler (void *d, SCM tag, SCM args)
 495 {
 496   /* Print a message.  Note that if TAG is `quit', this will exit() the
 497      process.  */
 498   scm_handle_by_message_noexit (NULL, tag, args);
 499
 500   return SCM_BOOL_F;
 501 }
 502
 503 SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
 504             (SCM proc),
 505 "Call @var{proc} and return its result.  Do not allow the invocation of\n"
 506 "continuations that would leave or enter the dynamic extent of the call\n"
 507 "to @code{with-continuation-barrier}.  Such an attempt causes an error\n"
 508 "to be signaled.\n"
 509 "\n"
 510 "Throws (such as errors) that are not caught from within @var{proc} are\n"
 511 "caught by @code{with-continuation-barrier}.  In that case, a short\n"
 512 "message is printed to the current error port and @code{#f} is returned.\n"
 513 "\n"
 514 "Thus, @code{with-continuation-barrier} returns exactly once.\n")
 515 #define FUNC_NAME s_scm_with_continuation_barrier
 516 {
 517   struct scm_data scm_data;
 518   scm_data.proc = proc;
 519   return scm_i_with_continuation_barrier (scm_body, &scm_data,
 520                                           scm_handler, &scm_data,
 521                                           pre_unwind_handler,
 522                                           SCM_UNPACK_POINTER (scm_current_error_port ()));
 523 }
 524 #undef FUNC_NAME
 525
 526 void
 527 scm_init_continuations ()
 528 {
 529   tc16_continuation = scm_make_smob_type ("continuation", 0);
 530   scm_set_smob_print (tc16_continuation, continuation_print);
 531 #include "libguile/continuations.x"
 532 }
 533
 534 /*
 535   Local Variables:
 536   c-file-style: "gnu"
 537   End:
 538 */