continuations.c 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522
  1. /* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2014,2017-2018
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <assert.h>
  19. #include <string.h>
  20. #include <stdio.h>
  21. #if SCM_HAVE_AUXILIARY_STACK
  22. #include <ucontext.h>
  23. #endif
  24. #include "async.h"
  25. #include "backtrace.h"
  26. #include "boolean.h"
  27. #include "debug.h"
  28. #include "dynstack.h"
  29. #include "eval.h"
  30. #include "gsubr.h"
  31. #include "init.h"
  32. #include "instructions.h"
  33. #include "jit.h"
  34. #include "list.h"
  35. #include "numbers.h"
  36. #include "pairs.h"
  37. #include "ports.h"
  38. #include "smob.h"
  39. #include "stackchk.h"
  40. #include "stacks.h"
  41. #include "symbols.h"
  42. #include "vm.h"
  43. #include "continuations.h"
  44. static scm_t_bits tc16_continuation;
  45. #define SCM_CONTREGSP(x) SCM_TYP16_PREDICATE (tc16_continuation, x)
  46. #define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
  47. #define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
  48. #define SCM_SET_CONTINUATION_LENGTH(x, n)\
  49. (SCM_CONTREGS (x)->num_stack_items = (n))
  50. #define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
  51. #define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
  52. #define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
  53. /* scm_i_make_continuation will return a procedure whose code will
  54. reinstate the continuation. Here, as in gsubr.c, we define the form
  55. of that trampoline function.
  56. */
  57. struct goto_continuation_code
  58. {
  59. struct scm_jit_function_data data;
  60. uint32_t code[3];
  61. };
  62. struct goto_continuation_code goto_continuation_code = {
  63. {
  64. /* mcode = */ 0,
  65. /* counter = */ 0,
  66. /* start = */ sizeof (struct scm_jit_function_data),
  67. /* end = */ sizeof (struct scm_jit_function_data) + 12
  68. },
  69. {
  70. SCM_PACK_OP_24 (instrument_entry, 0),
  71. ((uint32_t) -(sizeof (struct scm_jit_function_data) / 4)),
  72. SCM_PACK_OP_24 (continuation_call, 0),
  73. }
  74. };
  75. static SCM
  76. make_continuation_trampoline (SCM contregs)
  77. {
  78. SCM ret;
  79. scm_t_bits nfree = 1;
  80. scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
  81. ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
  82. SCM_SET_CELL_WORD_1 (ret, goto_continuation_code.code);
  83. SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
  84. return ret;
  85. }
  86. /* {Continuations}
  87. */
  88. static int
  89. continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
  90. {
  91. scm_t_contregs *continuation = SCM_CONTREGS (obj);
  92. scm_puts ("#<continuation ", port);
  93. scm_intprint (continuation->num_stack_items, 10, port);
  94. scm_puts (" @ ", port);
  95. scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
  96. scm_putc ('>', port);
  97. return 1;
  98. }
  99. /* James Clark came up with this neat one instruction fix for
  100. * continuations on the SPARC. It flushes the register windows so
  101. * that all the state of the process is contained in the stack.
  102. */
  103. #if defined (sparc) || defined (__sparc__) || defined (__sparc)
  104. # define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
  105. #else
  106. # define SCM_FLUSH_REGISTER_WINDOWS /* empty */
  107. #endif
  108. static void
  109. capture_auxiliary_stack (scm_thread *thread, scm_t_contregs *continuation)
  110. {
  111. #if SCM_HAVE_AUXILIARY_STACK
  112. # if !defined __ia64 || !defined __ia64__
  113. # error missing auxiliary stack implementation for architecture
  114. # endif
  115. char *top;
  116. ucontext_t ctx;
  117. if (getcontext (&ctx) != 0)
  118. abort ();
  119. #if defined __hpux
  120. __uc_get_ar_bsp (ctx, (uint64_t *) &top);
  121. #elif defined linux
  122. top = (char *) ctx.uc_mcontext.sc_ar_bsp;
  123. #elif defined __FreeBSD__
  124. top = (char *)(ctx.uc_mcontext.mc_special.bspstore
  125. + ctx->uc_mcontext.mc_special.ndirty);
  126. #else
  127. #error missing auxiliary stack implementation for ia64 on this OS
  128. #endif
  129. continuation->auxiliary_stack_size =
  130. top - (char *) thread->auxiliary_stack_base;
  131. continuation->auxiliary_stack =
  132. scm_gc_malloc (continuation->auxiliary_stack_size,
  133. "continuation auxiliary stack");
  134. memcpy (continuation->auxiliary_stack, thread->auxiliary_stack_base,
  135. continuation->auxiliary_stack_size);
  136. #endif /* SCM_HAVE_AUXILIARY_STACK */
  137. }
  138. static void
  139. restore_auxiliary_stack (scm_thread *thread, scm_t_contregs *continuation)
  140. {
  141. #if SCM_HAVE_AUXILIARY_STACK
  142. memcpy (thread->auxiliary_stack_base, continuation->auxiliary_stack,
  143. continuation->auxiliary_stack_size);
  144. #endif
  145. }
  146. SCM
  147. scm_i_make_continuation (scm_thread *thread, SCM vm_cont)
  148. {
  149. SCM cont;
  150. scm_t_contregs *continuation;
  151. long stack_size;
  152. SCM_STACKITEM * src;
  153. SCM_FLUSH_REGISTER_WINDOWS;
  154. stack_size = scm_stack_size (thread->continuation_base);
  155. continuation = scm_gc_malloc (sizeof (scm_t_contregs)
  156. + (stack_size - 1) * sizeof (SCM_STACKITEM),
  157. "continuation");
  158. continuation->num_stack_items = stack_size;
  159. continuation->root = thread->continuation_root;
  160. src = thread->continuation_base;
  161. #if ! SCM_STACK_GROWS_UP
  162. src -= stack_size;
  163. #endif
  164. continuation->offset = continuation->stack - src;
  165. memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
  166. memcpy (continuation->jmpbuf, thread->vm.registers, sizeof (jmp_buf));
  167. continuation->vm_cont = vm_cont;
  168. capture_auxiliary_stack (thread, continuation);
  169. SCM_NEWSMOB (cont, tc16_continuation, continuation);
  170. return make_continuation_trampoline (cont);
  171. }
  172. int
  173. scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
  174. {
  175. SCM contregs;
  176. scm_t_contregs *cont;
  177. contregs = SCM_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
  178. cont = SCM_CONTREGS (contregs);
  179. if (scm_is_true (cont->vm_cont))
  180. {
  181. struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
  182. frame->stack_holder = data;
  183. frame->fp_offset = data->fp_offset;
  184. frame->sp_offset = data->stack_size;
  185. frame->ip = data->vra;
  186. return 1;
  187. }
  188. else
  189. return 0;
  190. }
  191. scm_t_contregs *
  192. scm_i_contregs (SCM contregs)
  193. {
  194. if (!SCM_CONTREGSP (contregs))
  195. abort ();
  196. return SCM_CONTREGS (contregs);
  197. }
  198. /* {Apply}
  199. */
  200. /* Invoking a continuation proceeds as follows:
  201. *
  202. * - the stack is made large enough for the called continuation
  203. * - the old windchain is unwound down to the branching point
  204. * - the continuation stack is copied into place
  205. * - the windchain is rewound up to the continuation's context
  206. * - the continuation is invoked via longjmp (or setcontext)
  207. *
  208. * This order is important so that unwind and rewind handlers are run
  209. * with their correct stack.
  210. */
  211. static void scm_dynthrow (SCM, uint8_t *);
  212. /* Grow the stack by a fixed amount to provide space to copy in the
  213. * continuation. Possibly this function has to be called several times
  214. * recursively before enough space is available. Make sure the compiler does
  215. * not optimize the growth array away by storing it's address into a global
  216. * variable.
  217. */
  218. static scm_t_bits scm_i_dummy;
  219. static void
  220. grow_stack (SCM cont, uint8_t *mra)
  221. {
  222. scm_t_bits growth[100];
  223. scm_i_dummy = (scm_t_bits) growth;
  224. scm_dynthrow (cont, mra);
  225. }
  226. /* Copy the continuation stack into the current stack. Calling functions from
  227. * within this function is safe, since only stack frames below this function's
  228. * own frame are overwritten. Thus, memcpy can be used for best performance.
  229. */
  230. static void
  231. copy_stack_and_call (scm_t_contregs *continuation,
  232. SCM_STACKITEM * dst, uint8_t *mra)
  233. {
  234. scm_t_dynstack *dynstack;
  235. scm_t_bits *joint;
  236. scm_thread *thread = SCM_I_CURRENT_THREAD;
  237. dynstack = SCM_VM_CONT_DATA (continuation->vm_cont)->dynstack;
  238. joint = scm_dynstack_unwind_fork (&thread->dynstack, dynstack);
  239. memcpy (dst, continuation->stack,
  240. sizeof (SCM_STACKITEM) * continuation->num_stack_items);
  241. restore_auxiliary_stack (thread, continuation);
  242. scm_dynstack_wind (&thread->dynstack, joint);
  243. thread->vm.mra_after_abort = mra;
  244. longjmp (continuation->jmpbuf, 1);
  245. }
  246. /* Call grow_stack until the stack space is large enough, then, as the current
  247. * stack frame might get overwritten, let copy_stack_and_call perform the
  248. * actual copying and continuation calling.
  249. */
  250. static void
  251. scm_dynthrow (SCM cont, uint8_t *mra)
  252. {
  253. scm_thread *thread = SCM_I_CURRENT_THREAD;
  254. scm_t_contregs *continuation = SCM_CONTREGS (cont);
  255. SCM_STACKITEM *dst = thread->continuation_base;
  256. SCM_STACKITEM stack_top_element;
  257. #if SCM_STACK_GROWS_UP
  258. if (dst + continuation->num_stack_items >= &stack_top_element)
  259. grow_stack (cont, mra);
  260. #else
  261. dst -= continuation->num_stack_items;
  262. if (dst <= &stack_top_element)
  263. grow_stack (cont, mra);
  264. #endif /* def SCM_STACK_GROWS_UP */
  265. SCM_FLUSH_REGISTER_WINDOWS;
  266. copy_stack_and_call (continuation, dst, mra);
  267. }
  268. void
  269. scm_i_reinstate_continuation (SCM cont, uint8_t *mra)
  270. {
  271. scm_dynthrow (cont, mra);
  272. abort (); /* Unreachable. */
  273. }
  274. SCM
  275. scm_i_with_continuation_barrier (scm_t_catch_body body,
  276. void *body_data,
  277. scm_t_catch_handler handler,
  278. void *handler_data,
  279. scm_t_catch_handler pre_unwind_handler,
  280. void *pre_unwind_handler_data)
  281. {
  282. SCM_STACKITEM stack_item;
  283. scm_thread *thread = SCM_I_CURRENT_THREAD;
  284. SCM old_controot;
  285. SCM_STACKITEM *old_contbase;
  286. SCM result;
  287. /* Establish a fresh continuation root.
  288. */
  289. old_controot = thread->continuation_root;
  290. old_contbase = thread->continuation_base;
  291. thread->continuation_root = scm_cons (thread->handle, old_controot);
  292. thread->continuation_base = &stack_item;
  293. /* Call FUNC inside a catch all. This is now guaranteed to return
  294. directly and exactly once.
  295. */
  296. result = scm_c_catch (SCM_BOOL_T,
  297. body, body_data,
  298. handler, handler_data,
  299. pre_unwind_handler, pre_unwind_handler_data);
  300. /* Return to old continuation root.
  301. */
  302. thread->continuation_base = old_contbase;
  303. thread->continuation_root = old_controot;
  304. return result;
  305. }
  306. static int
  307. should_print_backtrace (SCM tag, SCM stack)
  308. {
  309. return SCM_BACKTRACE_P
  310. && scm_is_true (stack)
  311. && scm_initialized_p
  312. /* It's generally not useful to print backtraces for errors reading
  313. or expanding code in these fallback catch statements. */
  314. && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
  315. && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
  316. }
  317. static void
  318. print_exception_and_backtrace (SCM port, SCM tag, SCM args)
  319. {
  320. SCM stack, frame;
  321. /* We get here via a throw to a catch-all. In that case there is the
  322. throw frame active, and this catch closure, so narrow by two
  323. frames. */
  324. stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
  325. frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
  326. if (should_print_backtrace (tag, stack))
  327. {
  328. scm_puts ("Backtrace:\n", port);
  329. scm_display_backtrace_with_highlights (stack, port,
  330. SCM_BOOL_F, SCM_BOOL_F,
  331. SCM_EOL);
  332. scm_newline (port);
  333. }
  334. scm_print_exception (port, frame, tag, args);
  335. }
  336. struct c_data {
  337. void *(*func) (void *);
  338. void *data;
  339. void *result;
  340. };
  341. static SCM
  342. c_body (void *d)
  343. {
  344. struct c_data *data = (struct c_data *)d;
  345. data->result = data->func (data->data);
  346. return SCM_UNSPECIFIED;
  347. }
  348. static SCM
  349. c_handler (void *d, SCM tag, SCM args)
  350. {
  351. struct c_data *data;
  352. /* If TAG is `quit', exit() the process. */
  353. if (scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
  354. exit (scm_exit_status (args));
  355. data = (struct c_data *)d;
  356. data->result = NULL;
  357. return SCM_UNSPECIFIED;
  358. }
  359. static SCM
  360. pre_unwind_handler (void *error_port, SCM tag, SCM args)
  361. {
  362. /* Print the exception unless TAG is `quit'. */
  363. if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
  364. print_exception_and_backtrace (SCM_PACK_POINTER (error_port), tag, args);
  365. return SCM_UNSPECIFIED;
  366. }
  367. void *
  368. scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
  369. {
  370. struct c_data c_data;
  371. c_data.func = func;
  372. c_data.data = data;
  373. scm_i_with_continuation_barrier (c_body, &c_data,
  374. c_handler, &c_data,
  375. pre_unwind_handler,
  376. SCM_UNPACK_POINTER (scm_current_error_port ()));
  377. return c_data.result;
  378. }
  379. struct scm_data {
  380. SCM proc;
  381. };
  382. static SCM
  383. scm_body (void *d)
  384. {
  385. struct scm_data *data = (struct scm_data *)d;
  386. return scm_call_0 (data->proc);
  387. }
  388. static SCM
  389. scm_handler (void *d, SCM tag, SCM args)
  390. {
  391. /* Print a message. Note that if TAG is `quit', this will exit() the
  392. process. */
  393. scm_handle_by_message_noexit (NULL, tag, args);
  394. return SCM_BOOL_F;
  395. }
  396. SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
  397. (SCM proc),
  398. "Call @var{proc} and return its result. Do not allow the invocation of\n"
  399. "continuations that would leave or enter the dynamic extent of the call\n"
  400. "to @code{with-continuation-barrier}. Such an attempt causes an error\n"
  401. "to be signaled.\n"
  402. "\n"
  403. "Throws (such as errors) that are not caught from within @var{proc} are\n"
  404. "caught by @code{with-continuation-barrier}. In that case, a short\n"
  405. "message is printed to the current error port and @code{#f} is returned.\n"
  406. "\n"
  407. "Thus, @code{with-continuation-barrier} returns exactly once.\n")
  408. #define FUNC_NAME s_scm_with_continuation_barrier
  409. {
  410. struct scm_data scm_data;
  411. scm_data.proc = proc;
  412. return scm_i_with_continuation_barrier (scm_body, &scm_data,
  413. scm_handler, &scm_data,
  414. pre_unwind_handler,
  415. SCM_UNPACK_POINTER (scm_current_error_port ()));
  416. }
  417. #undef FUNC_NAME
  418. void
  419. scm_init_continuations ()
  420. {
  421. tc16_continuation = scm_make_smob_type ("continuation", 0);
  422. scm_set_smob_print (tc16_continuation, continuation_print);
  423. #include "continuations.x"
  424. }