1 /* continuations.c -- continuations, much stack hackery..
2 Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
3 $Id$
4
5 This file is part of librep.
6
7 librep is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 librep is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with librep; see the file COPYING. If not, write to
19 the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
20
21 /* notes:
22
23 The basic idea is to copy the entire active stack into the
24 continuation, together with a jmpbuf and the pointers into the stack
25 stored lisp histories (lisp call stack, gc roots, blocked file
26 operations, saved regexp data, etc..)
27
28 When the continuation is activated, the stack is built up so that
29 it's large enough to contain the saved stack in the continuation.
30 The saved version is then copied over the current stack, and the
31 jmpbuf is called
32
33 Marking a continuation involves marking all the lisp histories, but
34 remembering to relocate into the copied stack data
35
36 Some of the ideas here were inspired by the SCM/Guile implementation
37 of continuations.
38
39 We also use continuation `barriers'. A barrier marks a (possibly
40 saved) stack position, and can be either `open' or `closed'. There
41 is a tree of barriers, branches of which may be stored in
42 continuations, or on the current stack.
43
44 When invoking a continuation it is forbidden to cross any closed
45 barriers. Each barrier has two functions `in' and `out' associated
46 with it, one of these may be invoked when a continuation is invoked
47 and the barrier is crossed. These functions are normally used for
48 setting and unsetting global state.
49
50 Note that continuations only save and restore variable bindings
51 (both lexical and dynamic). It doesn't make sense to save other
52 dynamic state (i.e. catch/throw, unwind-protect, etc..), though it
53 could be done using open barriers..
54
55 Hopefully this will be reasonably portable, I _think_ it only
56 depends on having a linear stack that completely encapsulates the
57 current process state, and a setjmp/longjmp implementation..
58
59 Continuations are also used to provide a basic threading
60 implementation. Threads are local to each enclosing closed barrier
61 (dynamic root). Each barrier has two thread queues, runnable and
62 suspended. Each thread is just a (primitive) continuation, the
63 lexical environment, and a forbid-preemption count. The dynamic root
64 acts as a serialization point, it will only be crossed when the last
65 thread has exited or been deleted.
66
67 To avoid having to consider preemption throughout the interpreter,
68 there are only (currently) two preemption points, in funcall and the
69 bytecode interpreter. The rep_test_int_counter is used to decide
70 when to try to preempt the current thread. In non-threaded mode
71 (i.e. thread_invoke () hasn't been called in the current root),
72 these are all no-ops. The rep_TEST_INT_SLOW macro is also allowed to
73 preempt.
74
75 Finally, here's an example of using threads:
76
77 (defvar *counter* nil)
78
79 (defun thread-fun (id)
80 (let
81 ((*counter* (* id 1000)))
82 (while t
83 (format standard-output "thread-%s: %8d\n" id *counter*)
84 (setq *counter* (1+ *counter*)))))
85
86 (setq thread-1 (make-thread (lambda () (thread-fun 1)) "thread-1"))
87 (setq thread-2 (make-thread (lambda () (thread-fun 2)) "thread-2"))
88
89 [ the dynamic root is a serialization point, it won't be exited
90 until _all_ threads it contains have exited / been deleted, or it's
91 been thrown threw (which deletes all running threads) ]
92
93 The lisp debugger runs in it's own dynamic root, so debugging
94 threads works for free! */
95
96 #define _GNU_SOURCE
97 #undef DEBUG
98
99 /* AIX requires this to be the first thing in the file. */
100 #include <config.h>
101 #ifdef __GNUC__
102 # define alloca __builtin_alloca
103 #else
104 # if HAVE_ALLOCA_H
105 # include <alloca.h>
106 # else
107 # ifdef _AIX
108 #pragma alloca
109 # else
110 # ifndef alloca /* predefined by HP cc +Olibcalls */
111 char *alloca ();
112 # endif
113 # endif
114 # endif
115 #endif
116
117 #include "repint.h"
118 #include <string.h>
119 #include <stdlib.h>
120 #include <assert.h>
121 #include <setjmp.h>
122 #include <limits.h>
123
124 #ifdef NEED_MEMORY_H
125 # include <memory.h>
126 #endif
127
128 #ifdef HAVE_SYS_TIME_H
129 # include <sys/time.h>
130 #endif
131
132 #if defined (DEBUG)
133 # define DB(x) printf x
134 #else
135 # define DB(x)
136 #endif
137
138 /* Threads only preempted when this is zero. */
139 int rep_thread_lock = 0;
140
141 /* True when the current thread should be preempted soon */
142 rep_bool rep_pending_thread_yield;
143
144 #ifdef WITH_CONTINUATIONS
145
146 #if STACK_DIRECTION == 0
147 # error "stack growth direction unknown"
148 #elif STACK_DIRECTION > 0
149 # warning "upward growing stacks are untested"
150 #endif
151
152 #if STACK_DIRECTION < 0
153 /* was address B1 put on the stack _before_ address B2? */
154 # define SP_OLDER_P(b1, b2) ((b1) > (b2))
155 /* was address B1 put on the stack _after_ address B2? */
156 # define SP_NEWER_P(b1, b2) ((b1) < (b2))
157 #else
158 # define SP_OLDER_P(b1, b2) ((b1) < (b2))
159 # define SP_NEWER_P(b1, b2) ((b1) > (b2))
160 #endif
161
162 /* copied from guile 1.3.2 */
163 #if !defined (FLUSH_REGISTER_WINDOWS)
164 # if defined (sparc)
165 # define FLUSH_REGISTER_WINDOWS asm ("ta 3")
166 # else
167 # define FLUSH_REGISTER_WINDOWS
168 # endif
169 #endif
170
171 typedef struct rep_barrier_struct rep_barrier;
172 typedef struct rep_continuation_struct rep_continuation;
173 typedef struct rep_thread_struct rep_thread;
174
175 /* Continuations can only be invoked if there's no closed barriers
176 between the current stack address and the address contained in the
177 continuation. Open barriers are simply used for context switching
178 globally-stored state
179
180 Barriers also allow us to be selective about how much of the stack
181 is saved for each continuation. Only the portion more recent than
182 the most recent closed barrier is saved. */
183
184 struct rep_barrier_struct {
185 rep_barrier *next;
186 rep_barrier *root; /* upwards closed barrier */
187 char *point;
188 void (*in)(void *data);
189 void (*out)(void *data);
190 void *data;
191 rep_thread *active;
192 rep_thread *head, *tail;
193 rep_thread *susp_head, *susp_tail;
194 short depth;
195 unsigned int closed : 1;
196 unsigned int targeted : 1; /* may contain continuations */
197 };
198
199 /* List of all currently active barriers (on the current stack) */
200 static rep_barrier *barriers;
201
202 /* The outermost active closed barrier (the dynamic root in guile terms?) */
203 static rep_barrier *root_barrier;
204
205 /* Put in rep_throw_value when the enclosing closed barrier needs to exit */
206 static repv exit_barrier_cell;
207
208 /* The data saved for a continuation */
209 struct rep_continuation_struct {
210 repv car;
211 rep_continuation *next;
212
213 jmp_buf jmpbuf;
214 char *stack_copy, *stack_top, *stack_bottom;
215 size_t stack_size, real_size;
216
217 rep_barrier *barriers;
218 rep_barrier *root;
219
220 struct rep_Call *call_stack;
221 repv special_bindings;
222 rep_GC_root *gc_roots;
223 rep_GC_n_roots *gc_n_roots;
224 struct rep_saved_regexp_data *regexp_data;
225 struct blocked_op *blocked_ops[op_MAX];
226 repv throw_value;
227 rep_bool single_step;
228 int lisp_depth;
229 };
230
231 #define rep_CONTIN(v) ((rep_continuation *)rep_PTR(v))
232 #define rep_CONTINP(v) rep_CELL16_TYPEP(v, continuation_type ())
233
234 #define CF_INVALID (1 << rep_CELL16_TYPE_BITS)
235
236 #define CONTIN_MAX_SLOP 4096
237
238 /* returns the cell16 typecode allocated for continuation objects */
239 static int continuation_type (void);
240
241 /* list of all allocated continuations */
242 static rep_continuation *continuations;
243
244 struct rep_thread_struct {
245 repv car;
246 rep_thread *next_alloc;
247 rep_thread *next, *pred;
248 repv name;
249 rep_continuation *cont;
250 repv env, structure;
251 int lock;
252 struct timeval run_at;
253 rep_bool (*poll)(rep_thread *t, void *arg);
254 void *poll_arg;
255 repv exit_val;
256 };
257
258 #define XTHREADP(v) rep_CELL16_TYPEP(v, thread_type ())
259 #define THREADP(v) (XTHREADP (v) && !(THREAD (v)->car & TF_EXITED))
260 #define THREAD(v) ((rep_thread *) rep_PTR (v))
261
262 #define TF_EXITED (1 << (rep_CELL16_TYPE_BITS + 0))
263 #define TF_SUSPENDED (1 << (rep_CELL16_TYPE_BITS + 1))
264
265 static int thread_type (void);
266 static rep_thread *threads;
267
268 #define TV_LATER_P(t1, t2) \
269 (((t1)->tv_sec > (t2)->tv_sec) \
270 || (((t1)->tv_sec == (t2)->tv_sec) \
271 && ((t1)->tv_usec > (t2)->tv_usec)))
272
273 DEFSYM(continuation, "continuation");
274
275 /* used while longjmp'ing to save accessing a local variable */
276 static rep_continuation *invoked_continuation;
277 static repv invoked_continuation_ret;
278 static rep_barrier *invoked_continuation_ancestor;
279
280 /* Approx. number of extra bytes of stack per recursion */
281 #define STACK_GROWTH 512
282
283 static inline char *
fixup(char * addr,rep_continuation * c)284 fixup (char *addr, rep_continuation *c)
285 {
286 #if STACK_DIRECTION < 0
287 if (addr < c->stack_bottom)
288 return (addr - c->stack_top) + c->stack_copy;
289 else
290 return addr;
291 #else
292 if (addr > c->stack_bottom)
293 return (addr - c->stack_bottom) + c->stack_copy;
294 else
295 return addr;
296 #endif
297 }
298
299 #define FIXUP(t,c,addr) ((t) (fixup ((char *) (addr), (c))))
300
301 static void thread_delete (rep_thread *t);
302
303
304 /* barriers */
305
306 /* Create a barrier (closed if CLOSED is true, open otherwise), then
307 call CALLBACK with ARG as its argument. The barrier will be in place
308 for the duration of the call to CALLBACK.
309
310 If either of IN or OUT aren't null pointers then they will be called
311 when the barrier is crossed (while invoking a continuation). Closed
312 barriers are never crossed. DATA is passed to both IN and OUT
313 functions when they are called.
314
315 The IN function is called when control passes from above barrier on
316 the stack to below; OUT when control passes from below to above. */
317 repv
rep_call_with_barrier(repv (* callback)(repv),repv arg,rep_bool closed,void (* in)(void *),void (* out)(void *),void * data)318 rep_call_with_barrier (repv (*callback)(repv), repv arg,
319 rep_bool closed, void (*in)(void *),
320 void (*out)(void *), void *data)
321 {
322 repv ret;
323 rep_barrier b;
324
325 memset (&b, 0, sizeof (b));
326 b.point = (char *) &b;
327 #if STACK_DIRECTION > 0
328 b.point += sizeof (rep_barrier); /* don't want to save barrier */
329 #endif
330 b.root = root_barrier;
331 b.in = in;
332 b.out = out;
333 b.data = data;
334 b.closed = closed;
335 b.depth = barriers ? barriers->depth + 1 : 1;
336
337 b.next = barriers;
338 barriers = &b;
339
340 if (closed)
341 root_barrier = &b;
342
343 DB(("with-barrier[%s]: in %p (%d)\n",
344 closed ? "closed" : "open", &b, b.depth));
345
346 ret = callback (arg);
347
348 if (closed)
349 {
350 rep_thread *ptr;
351
352 again:
353 if (rep_throw_value == exit_barrier_cell)
354 {
355 DB (("caught barrier exit throw\n"));
356 rep_throw_value = rep_CDR (exit_barrier_cell);
357 ret = (rep_throw_value == rep_NULL) ? Qnil : rep_NULL;
358 rep_CDR (exit_barrier_cell) = Qnil;
359 }
360
361 if (rep_throw_value == rep_NULL && b.active != 0)
362 {
363 /* An active thread exited. Calling thread_delete () on the
364 active thread will call thread_invoke (). That will
365 exit if there are no more runnable threads. */
366 DB (("deleting active thread %p\n", b.active));
367 thread_delete (b.active);
368 goto again;
369 }
370
371 if (b.targeted)
372 {
373 /* Invalidate any continuations that require this barrier */
374 rep_continuation *c;
375 for (c = continuations; c != 0; c = c->next)
376 {
377 if (c->root == &b)
378 c->car |= CF_INVALID;
379 }
380 }
381
382 for (ptr = b.head; ptr != 0; ptr = ptr->next)
383 ptr->car |= TF_EXITED;
384 for (ptr = b.susp_head; ptr != 0; ptr = ptr->next)
385 ptr->car |= TF_EXITED;
386 if (b.active != 0)
387 b.active->car |= TF_EXITED;
388 }
389
390 DB(("with-barrier[%s]: out %p (%d)\n",
391 closed ? "closed" : "open", &b, b.depth));
392
393 barriers = b.next;
394 root_barrier = b.root;
395 return ret;
396 }
397
398 static rep_barrier *
get_dynamic_root(int depth)399 get_dynamic_root (int depth)
400 {
401 rep_barrier *root = root_barrier;
402 while (depth-- > 0 && root != 0)
403 root = root->root;
404 return root;
405 }
406
407 /* Record all barriers from continuation C's outermost barrier into the
408 array HIST, stopping at the first closed barrier encountered.
409 Returns the total number of barrier placed in HIST. */
410 static int
trace_barriers(rep_continuation * c,rep_barrier ** hist)411 trace_barriers (rep_continuation *c, rep_barrier **hist)
412 {
413 int i;
414 rep_barrier *ptr = FIXUP (rep_barrier *, c, c->barriers);
415 for (i = 0; ptr != 0; ptr = FIXUP (rep_barrier *, c, ptr->next))
416 {
417 hist[i++] = ptr;
418 if (ptr->closed)
419 break;
420 }
421 return i;
422 }
423
424 /* Find the most recent common ancestor of barrier CURRENT, and the
425 list of barriers in DEST-HIST (containing DEST-DEPTH pointers).
426 Returns a null pointer if no such barrier can be found. */
427 static rep_barrier *
common_ancestor(rep_barrier * current,rep_barrier ** dest_hist,int dest_depth)428 common_ancestor (rep_barrier *current, rep_barrier **dest_hist, int dest_depth)
429 {
430 rep_barrier *ptr;
431 int first_dest = 0;
432
433 for (ptr = current; ptr != 0; ptr = ptr->next)
434 {
435 int i;
436 for (i = first_dest; i < dest_depth; i++)
437 {
438 if (dest_hist[i]->point == ptr->point)
439 return ptr;
440 else if (SP_NEWER_P (dest_hist[i]->point, ptr->point))
441 first_dest = i + 1;
442 }
443 if (ptr->closed)
444 break;
445 }
446
447 return 0;
448 }
449
450
451 /* continuations */
452
453 /* save the original stack for continuation C */
454 static void
save_stack(rep_continuation * c)455 save_stack (rep_continuation *c)
456 {
457 size_t size;
458
459 FLUSH_REGISTER_WINDOWS;
460
461 /* __builtin_frame_address doesn't give the right thing on athlon64 */
462
463 #if defined (__GNUC__) && !defined (BROKEN_ALPHA_GCC) && !defined (__x86_64)
464 c->stack_top = __builtin_frame_address (0);
465 #else
466 c->stack_top = (char *) &size;
467 #endif
468
469 #if STACK_DIRECTION < 0
470 size = c->stack_bottom - c->stack_top;
471 #else
472 size = c->stack_top - c->stack_bottom;
473 #endif
474
475 if (c->stack_copy != 0)
476 {
477 if (c->stack_size < size || (c->stack_size - size) > CONTIN_MAX_SLOP)
478 {
479 rep_free (c->stack_copy);
480 rep_data_after_gc -= c->stack_size;
481 c->stack_copy = 0;
482 }
483 }
484
485 if (c->stack_copy == 0)
486 {
487 c->stack_size = size;
488 c->stack_copy = rep_alloc (size);
489 rep_data_after_gc += size;
490 }
491
492 c->real_size = size;
493 #if STACK_DIRECTION < 0
494 memcpy (c->stack_copy, c->stack_top, c->real_size);
495 #else
496 memcpy (c->stack_copy, c->stack_bottom, c->real_size);
497 #endif
498 }
499
500 /* Make sure that the current frame has enough space under it to
501 hold the saved copy in C, then invoke the continuation */
502 static void
grow_stack_and_invoke(rep_continuation * c,char * water_mark)503 grow_stack_and_invoke (rep_continuation *c, char *water_mark)
504 {
505 volatile char growth[STACK_GROWTH];
506
507 /* if stack isn't large enough, recurse again */
508
509 #if STACK_DIRECTION < 0
510 if (water_mark >= c->stack_top)
511 grow_stack_and_invoke (c, (char *) growth + STACK_GROWTH);
512 #else
513 if (water_mark <= c->stack_top)
514 grow_stack_and_invoke (c, (char *) growth);
515 #endif
516
517 FLUSH_REGISTER_WINDOWS;
518
519 /* stack's big enough now, so reload the saved copy somewhere
520 below the current position. */
521
522 #if STACK_DIRECTION < 0
523 memcpy (c->stack_top, c->stack_copy, c->real_size);
524 #else
525 memcpy (c->stack_bottom, c->stack_copy, c->real_size);
526 #endif
527
528 longjmp (c->jmpbuf, 1);
529 }
530
531 static void
primitive_invoke_continuation(rep_continuation * c,repv ret)532 primitive_invoke_continuation (rep_continuation *c, repv ret)
533 {
534 char water_mark;
535 rep_barrier **dest_hist = 0, *dest_root = 0, *anc, *ptr;
536 int depth;
537
538 /* try to find a route from the current root barrier to the
539 root barrier of the continuation, without crossing any
540 closed barriers */
541
542 dest_root = FIXUP (rep_barrier *, c, c->barriers);
543 dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
544 depth = trace_barriers (c, dest_hist);
545
546 anc = common_ancestor (barriers, dest_hist, depth);
547 if (anc == 0)
548 {
549 DEFSTRING (unreachable, "unreachable continuation");
550 Fsignal (Qerror, rep_LIST_1 (rep_VAL (&unreachable)));
551 return;
552 }
553
554 /* Handle any `out' barrier functions */
555 for (ptr = barriers; ptr != anc; ptr = ptr->next)
556 {
557 DB (("invoke: outwards through %p (%d)\n", ptr, ptr->depth));
558 if (ptr->out != 0)
559 {
560 repv cont = rep_VAL (c);
561 rep_GC_root gc_cont, gc_ret;
562 rep_PUSHGC (gc_cont, cont);
563 rep_PUSHGC (gc_ret, ret);
564 ptr->out (ptr->data);
565 rep_POPGC; rep_POPGC;
566 }
567 }
568
569 /* save the return value and recurse up the stack until there's
570 room to invoke the continuation. Note that invoking this subr
571 will already have restored the original environment since the
572 call to Fmake_closure () will have saved its old state.. */
573
574 invoked_continuation = c;
575 invoked_continuation_ret = ret;
576 invoked_continuation_ancestor = anc;
577
578 DB (("invoke: calling continuation %p\n", c));
579 grow_stack_and_invoke (c, &water_mark);
580 }
581
582 /* The continuations passed in from Fcall_cc () are actually closures
583 around this subr. They have Qcontinuation bound to the primitive
584 continuation object in their lexical environment */
585 DEFUN("primitive-invoke-continuation", Fprimitive_invoke_continuation,
586 Sprimitive_invoke_continuation, (repv ret), rep_Subr1)
587 {
588 repv cont = Fsymbol_value (Qcontinuation, Qnil);
589
590 if (cont == rep_NULL || !rep_CONTINP(cont)
591 || (rep_CONTIN(cont)->car & CF_INVALID))
592 {
593 DEFSTRING (invalid, "invalid continuation");
594 return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&invalid)));
595 }
596
597 primitive_invoke_continuation (rep_CONTIN (cont), ret);
598 return rep_NULL;
599 }
600
601 static repv
get_cont(repv arg)602 get_cont (repv arg)
603 {
604 return Fsymbol_value (Qcontinuation, Qnil);
605 }
606
607 DEFUN("continuation-callable-p", Fcontinuation_callable_p,
608 Scontinuation_callable_p, (repv cont), rep_Subr1) /*
609 ::doc:rep.lang.interpreter#continuation-callable-p::
610 continuation-callable-p CONTINUATION
611
612 Returns `t' if the continuation object CONTINUATION from the current
613 execution point of the interpreter.
614 ::end:: */
615 {
616 rep_continuation *c;
617 rep_barrier **dest_hist = 0, *dest_root = 0, *anc;
618 int depth;
619
620 rep_DECLARE1(cont, rep_FUNARGP);
621 cont = rep_call_with_closure (cont, get_cont, Qnil);
622 if (cont == rep_NULL)
623 return rep_NULL;
624 rep_DECLARE1(cont, rep_CONTINP);
625 c = rep_CONTIN (cont);
626
627 if (c->car & CF_INVALID)
628 return Qnil;
629
630 /* copied from above function */
631
632 dest_root = FIXUP (rep_barrier *, c, c->barriers);
633 dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
634 depth = trace_barriers (c, dest_hist);
635
636 anc = common_ancestor (barriers, dest_hist, depth);
637 return anc == 0 ? Qnil : Qt;
638 }
639
640 static repv
primitive_call_cc(repv (* callback)(rep_continuation *,void *),void * data,rep_continuation * c)641 primitive_call_cc (repv (*callback)(rep_continuation *, void *), void *data,
642 rep_continuation *c)
643 {
644 struct rep_saved_regexp_data re_data;
645 repv ret;
646
647 if (root_barrier == 0)
648 {
649 DEFSTRING (no_root, "no dynamic root");
650 return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&no_root)));
651 }
652
653 if (c == 0)
654 {
655 c = rep_ALLOC_CELL (sizeof (rep_continuation));
656 rep_data_after_gc += sizeof (rep_continuation);
657 c->next = continuations;
658 continuations = c;
659 c->stack_copy = 0;
660 }
661
662 c->car = continuation_type ();
663
664 if (setjmp (c->jmpbuf))
665 {
666 /* back from call/cc */
667 rep_barrier *ancestor;
668
669 /* fish out the continuation (variable `c' may have been lost) */
670 c = invoked_continuation;
671 invoked_continuation = 0;
672
673 rep_lisp_depth = c->lisp_depth;
674 rep_single_step_flag = c->single_step;
675 rep_throw_value = c->throw_value;
676 memcpy (rep_blocked_ops, c->blocked_ops, sizeof (rep_blocked_ops));
677 rep_saved_matches = c->regexp_data;
678 rep_gc_n_roots_stack = c->gc_n_roots;
679 rep_gc_root_stack = c->gc_roots;
680 rep_special_bindings = c->special_bindings;
681 rep_call_stack = c->call_stack;
682 root_barrier = c->root;
683 barriers = c->barriers;
684
685 ret = invoked_continuation_ret;
686 invoked_continuation_ret = rep_NULL;
687
688 ancestor = invoked_continuation_ancestor;
689 invoked_continuation_ancestor = 0;
690
691 /* handle any `in' barrier functions */
692 if (barriers != 0)
693 {
694 int count = barriers->depth - (ancestor ? ancestor->depth : 0);
695 rep_barrier **hist = alloca (sizeof (rep_barrier *) * count);
696 rep_barrier *ptr;
697 int i = 0;
698
699 for (ptr = barriers; ptr != ancestor; ptr = ptr->next)
700 hist[i++] = ptr;
701 for (i = count - 1; i >= 0; i--)
702 {
703 ptr = hist[i];
704 DB (("invoke: inwards through %p (%d)\n", ptr, ptr->depth));
705 if (ptr->in != 0)
706 {
707 rep_GC_root gc_ret;
708 rep_PUSHGC (gc_ret, ret);
709 ptr->in (ptr->data);
710 rep_POPGC;
711 }
712 }
713 }
714
715 rep_pop_regexp_data ();
716 }
717 else
718 {
719 /* into call/cc */
720
721 rep_push_regexp_data (&re_data);
722
723 c->barriers = barriers;
724 c->root = root_barrier;
725 root_barrier->targeted = 1;
726 c->call_stack = rep_call_stack;
727 c->special_bindings = rep_special_bindings;
728 c->gc_roots = rep_gc_root_stack;
729 c->gc_n_roots = rep_gc_n_roots_stack;
730 c->regexp_data = rep_saved_matches;
731 memcpy (c->blocked_ops, rep_blocked_ops, sizeof (c->blocked_ops));
732 c->throw_value = rep_throw_value;
733 c->single_step = rep_single_step_flag;
734 c->lisp_depth = rep_lisp_depth;
735
736 c->stack_bottom = c->root->point;
737 save_stack (c);
738
739 DB (("call/cc: saved %p; real_size=%lu (%u)\n",
740 c, (unsigned long) c->real_size, rep_stack_bottom - c->stack_top));
741
742 ret = callback (c, data);
743
744 rep_pop_regexp_data ();
745 }
746
747 return ret;
748 }
749
750 static repv
inner_call_cc(rep_continuation * c,void * data)751 inner_call_cc (rep_continuation *c, void *data)
752 {
753 repv proxy;
754 proxy = Fmake_closure (rep_VAL(&Sprimitive_invoke_continuation), Qnil);
755 rep_FUNARG(proxy)->env
756 = rep_add_binding_to_env (rep_FUNARG(proxy)->env,
757 Qcontinuation, rep_VAL(c));
758 return rep_call_lisp1 ((repv) data, proxy);
759 }
760
761 DEFUN("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1) /*
762 ::doc:rep.lang.interpreter#call/cc::
763 call/cc FUNCTION
764
765 Invoke FUNCTION with a single parameter, the continuation function of
766 the current state of the interpreter. Subsequently calling the
767 continuation function (with an optional single argument) will pass
768 control immediately back to the statement following the call to the
769 `call/cc' function (even if that stack frame has since been exited).
770 ::end:: */
771 {
772 return primitive_call_cc (inner_call_cc, (void *) fun, 0);
773 }
774
775
776 /* threads */
777
778 static inline void
thread_save_environ(rep_thread * t)779 thread_save_environ (rep_thread *t)
780 {
781 t->env = rep_env;
782 t->structure = rep_structure;
783 }
784
785 static inline void
thread_load_environ(rep_thread * t)786 thread_load_environ (rep_thread *t)
787 {
788 rep_env = t->env;
789 rep_structure = t->structure;
790 }
791
792 static void
enqueue_thread(rep_thread * t,rep_barrier * root)793 enqueue_thread (rep_thread *t, rep_barrier *root)
794 {
795 assert (!(t->car & TF_EXITED));
796 if (!(t->car & TF_SUSPENDED))
797 {
798 t->pred = root->tail;
799 if (t->pred != 0)
800 t->pred->next = t;
801 if (root->head == 0)
802 root->head = t;
803 root->tail = t;
804 }
805 else
806 {
807 rep_thread *ptr = root->susp_head;
808 while (ptr != 0 && TV_LATER_P (&t->run_at, &ptr->run_at))
809 ptr = ptr->next;
810 if (ptr != 0)
811 {
812 t->pred = ptr->pred;
813 if (ptr->pred != 0)
814 ptr->pred->next = t;
815 else
816 root->susp_head = t;
817 ptr->pred = t;
818 t->next = ptr;
819 }
820 else
821 {
822 t->pred = root->susp_tail;
823 if (t->pred != 0)
824 t->pred->next = t;
825 if (root->susp_head == 0)
826 root->susp_head = t;
827 root->susp_tail = t;
828 }
829 }
830 }
831
832 static void
unlink_thread(rep_thread * t)833 unlink_thread (rep_thread *t)
834 {
835 rep_barrier *root = t->cont->root;
836
837 if (t->pred != 0)
838 t->pred->next = t->next;
839 if (t->next != 0)
840 t->next->pred = t->pred;
841
842 if (!(t->car & TF_SUSPENDED))
843 {
844 if (root->head == t)
845 root->head = t->next;
846 if (root->tail == t)
847 root->tail = t->pred;
848 }
849 else
850 {
851 if (root->susp_head == t)
852 root->susp_head = t->next;
853 if (root->susp_tail == t)
854 root->susp_tail = t->pred;
855 }
856 t->next = t->pred = 0;
857 }
858
859 static void
thread_wake(rep_thread * t)860 thread_wake (rep_thread *t)
861 {
862 rep_barrier *root = t->cont->root;
863 assert (t->car & TF_SUSPENDED);
864 assert (!(t->car & TF_EXITED));
865
866 unlink_thread (t);
867 t->car &= ~TF_SUSPENDED;
868 enqueue_thread (t, root);
869 }
870
871 static rep_bool
poll_threads(rep_barrier * root)872 poll_threads (rep_barrier *root)
873 {
874 rep_bool woke_any = rep_FALSE;
875 rep_thread *t, *next;
876 for (t = root->susp_head; t != 0; t = next)
877 {
878 next = t->next;
879 if (t->poll && t->poll (t, t->poll_arg))
880 {
881 thread_wake (t);
882 woke_any = rep_TRUE;
883 }
884 }
885 return woke_any;
886 }
887
888 static repv
inner_thread_invoke(rep_continuation * c,void * data)889 inner_thread_invoke (rep_continuation *c, void *data)
890 {
891 rep_thread *t = data;
892 t->cont = c;
893 rep_thread_lock = root_barrier->head->lock;
894 DB (("invoking thread %p\n", root_barrier->head));
895 thread_load_environ (root_barrier->head);
896 primitive_invoke_continuation (root_barrier->head->cont, Qnil);
897 return rep_NULL;
898 }
899
900 static void
thread_invoke(void)901 thread_invoke (void)
902 {
903 again:
904 if (root_barrier == 0)
905 return;
906
907 if (root_barrier->head != 0)
908 {
909 rep_thread *active = root_barrier->active;
910 assert (root_barrier->head != 0);
911 root_barrier->active = root_barrier->head;
912 if (active != 0)
913 {
914 /* save the continuation of this thread,
915 then invoke the next thread */
916 active->lock = rep_thread_lock;
917 thread_save_environ (active);
918 primitive_call_cc (inner_thread_invoke, active, active->cont);
919 }
920 else
921 {
922 rep_thread_lock = root_barrier->head->lock;
923 DB (("invoking thread %p\n", root_barrier->head));
924 thread_load_environ (root_barrier->head);
925 primitive_invoke_continuation (root_barrier->head->cont, Qnil);
926 }
927 }
928 else
929 {
930 /* No thread to run. If no suspended threads return from the
931 root barrier. Else sleep.. */
932 if (root_barrier->susp_head == 0)
933 {
934 root_barrier->active = 0;
935 assert (rep_throw_value != exit_barrier_cell);
936 rep_CDR (exit_barrier_cell) = rep_throw_value;
937 rep_throw_value = exit_barrier_cell;
938 DB (("no more threads, throwing to root..\n"));
939 return;
940 }
941 else if (poll_threads (root_barrier))
942 {
943 /* something woke */
944 goto again;
945 }
946 else
947 {
948 rep_thread *b = root_barrier->susp_head;
949 struct timeval now;
950 gettimeofday (&now, 0);
951 DB (("no more threads, sleeping..\n"));
952 if (TV_LATER_P (&b->run_at, &now))
953 {
954 struct timeval delta;
955 delta.tv_sec = b->run_at.tv_sec - now.tv_sec;
956 delta.tv_usec = b->run_at.tv_usec - now.tv_usec;
957 while (delta.tv_usec < 0)
958 {
959 delta.tv_usec += 1000000;
960 delta.tv_sec--;
961 }
962 rep_sleep_for (delta.tv_sec, delta.tv_usec / 1000);
963 }
964 DB (("..waking thread %p\n", b));
965 thread_wake (b);
966 goto again;
967 }
968 }
969 }
970
971 static void
thread_delete(rep_thread * t)972 thread_delete (rep_thread *t)
973 {
974 rep_barrier *root = t->cont->root;
975 rep_thread *active = root->head;
976
977 unlink_thread (t);
978 t->car |= TF_EXITED;
979 if (active == t)
980 thread_invoke ();
981 }
982
983 static repv
inner_make_thread(rep_continuation * c,void * data)984 inner_make_thread (rep_continuation *c, void *data)
985 {
986 rep_thread *t = data;
987 t->cont = c;
988 enqueue_thread (t, t->cont->root);
989 return -1;
990 }
991
992 static rep_thread *
new_thread(repv name)993 new_thread (repv name)
994 {
995 rep_thread *t = rep_ALLOC_CELL (sizeof (rep_thread));
996 rep_data_after_gc += sizeof (rep_thread);
997 memset (t, 0, sizeof (rep_thread));
998 t->car = thread_type ();
999 t->name = name;
1000 t->poll = 0;
1001 t->poll_arg = 0;
1002 t->exit_val = rep_NULL;
1003 t->next_alloc = threads;
1004 threads = t;
1005 return t;
1006 }
1007
1008 static void
ensure_default_thread(void)1009 ensure_default_thread (void)
1010 {
1011 if (root_barrier->active == 0)
1012 {
1013 /* entering threaded execution. make the default thread */
1014 rep_thread *x = new_thread (Qnil);
1015 thread_save_environ (x);
1016 /* this continuation will never get called,
1017 but it simplifies things.. */
1018 if (primitive_call_cc (inner_make_thread, x, 0) != -1)
1019 abort ();
1020 root_barrier->active = x;
1021 }
1022 }
1023
1024 static rep_thread *
make_thread(repv thunk,repv name,rep_bool suspended)1025 make_thread (repv thunk, repv name, rep_bool suspended)
1026 {
1027 repv ret;
1028 rep_GC_root gc_thunk;
1029 rep_thread *t;
1030
1031 if (root_barrier == 0)
1032 return 0;
1033
1034 t = new_thread (name);
1035 if (suspended)
1036 t->car |= TF_SUSPENDED;
1037 thread_save_environ (t);
1038
1039 ensure_default_thread ();
1040
1041 rep_PUSHGC (gc_thunk, thunk);
1042 ret = primitive_call_cc (inner_make_thread, t, 0);
1043 rep_POPGC;
1044 if (ret == -1)
1045 return t;
1046 else
1047 {
1048 ret = rep_call_lisp0 (thunk);
1049 t->car |= TF_EXITED;
1050 if (ret != rep_NULL)
1051 {
1052 t->exit_val = ret;
1053 thread_delete (t);
1054 assert (rep_throw_value == exit_barrier_cell);
1055 }
1056 else
1057 {
1058 /* exited with a throw, throw out of the dynamic root */
1059 rep_CDR (exit_barrier_cell) = rep_throw_value;
1060 rep_throw_value = exit_barrier_cell;
1061 }
1062 return 0;
1063 }
1064 }
1065
1066 static rep_bool
thread_yield(void)1067 thread_yield (void)
1068 {
1069 struct timeval now;
1070 rep_thread *ptr, *next;
1071 rep_thread *old_head;
1072
1073 if (root_barrier == 0)
1074 return rep_FALSE;
1075
1076 old_head = root_barrier->head;
1077 rep_pending_thread_yield = rep_FALSE;
1078 if (root_barrier->head && root_barrier->head->next)
1079 {
1080 rep_thread *old = root_barrier->head;
1081 if (old->pred != 0)
1082 old->pred->next = old->next;
1083 if (old->next != 0)
1084 old->next->pred = old->pred;
1085 root_barrier->head = old->next;
1086 old->next = 0;
1087 old->pred = root_barrier->tail;
1088 old->pred->next = old;
1089 root_barrier->tail = old;
1090 }
1091
1092 /* check suspend queue for threads that need waking */
1093
1094 if (root_barrier->susp_head != 0)
1095 gettimeofday (&now, 0);
1096 for (ptr = root_barrier->susp_head; ptr != 0; ptr = next)
1097 {
1098 next = ptr->next;
1099 if (TV_LATER_P (&now, &ptr->run_at)
1100 || (ptr->poll && ptr->poll (ptr, ptr->poll_arg)))
1101 {
1102 thread_wake (ptr);
1103 }
1104 }
1105
1106 if (root_barrier->head != old_head)
1107 {
1108 thread_invoke ();
1109 return rep_TRUE;
1110 }
1111 else
1112 return rep_FALSE;
1113 }
1114
1115 static void
thread_suspend(rep_thread * t,unsigned long msecs,rep_bool (* poll)(rep_thread * t,void * arg),void * poll_arg)1116 thread_suspend (rep_thread *t, unsigned long msecs,
1117 rep_bool (*poll)(rep_thread *t, void *arg), void *poll_arg)
1118 {
1119 rep_barrier *root = t->cont->root;
1120 assert (!(t->car & TF_SUSPENDED));
1121 assert (!(t->car & TF_EXITED));
1122
1123 unlink_thread (t);
1124 t->car |= TF_SUSPENDED;
1125 if (msecs == 0)
1126 {
1127 /* XXX assumes twos-complement representation.. but Solaris
1128 XXX has a weird struct timeval.. */
1129 t->run_at.tv_sec = ~0UL >> 1;
1130 t->run_at.tv_usec = ~0UL >> 1;
1131 }
1132 else
1133 {
1134 gettimeofday (&t->run_at, 0);
1135 t->run_at.tv_sec += (msecs / 1000);
1136 t->run_at.tv_usec += (msecs % 1000) * 1000;
1137 if (t->run_at.tv_usec > 1000000)
1138 {
1139 t->run_at.tv_sec += t->run_at.tv_usec / 1000000;
1140 t->run_at.tv_usec = t->run_at.tv_usec % 1000000;
1141 }
1142 }
1143 t->poll = poll;
1144 t->poll_arg = poll_arg;
1145 t->exit_val = Qnil;
1146 enqueue_thread (t, root);
1147 if (root_barrier->active == t)
1148 thread_invoke ();
1149 }
1150
1151 unsigned long
rep_max_sleep_for(void)1152 rep_max_sleep_for (void)
1153 {
1154 rep_barrier *root = root_barrier;
1155 if (root == 0 || root->active == 0)
1156 {
1157 /* not using threads, sleep as long as you like..
1158 XXX grr.. using ULONG_MAX doesn't work on solaris*/
1159 return UINT_MAX;
1160 }
1161 else if (root->head != 0 && root->head->next != 0)
1162 {
1163 /* other threads ready to run, don't sleep */
1164 return 0;
1165 }
1166 else if (root->susp_head != 0)
1167 {
1168 /* other threads sleeping, how long until the first wakes? */
1169 /* XXX ignores polling */
1170 struct timeval now;
1171 long msecs;
1172 gettimeofday (&now, 0);
1173 msecs = ((root->susp_head->run_at.tv_sec - now.tv_sec) * 1000
1174 + (root->susp_head->run_at.tv_usec - now.tv_usec) / 1000);
1175 return MAX (msecs, 0);
1176 }
1177 else
1178 {
1179 /* whatever.. */
1180 return UINT_MAX;
1181 }
1182 }
1183
1184
1185 /* type hooks */
1186
1187 static void
mark_cont(repv obj)1188 mark_cont (repv obj)
1189 {
1190 rep_GC_root *roots;
1191 rep_GC_n_roots *nroots;
1192 struct rep_Call *calls;
1193 struct rep_saved_regexp_data *matches;
1194 rep_barrier *barrier;
1195
1196 rep_continuation *c = rep_CONTIN (obj);
1197 rep_MARKVAL (c->throw_value);
1198 rep_MARKVAL (c->special_bindings);
1199
1200 for (barrier = c->barriers;
1201 barrier != 0 && !SP_OLDER_P ((char *) barrier, c->stack_bottom);
1202 barrier = FIXUP(rep_barrier *, c, barrier)->next)
1203 {
1204 rep_barrier *ptr = FIXUP (rep_barrier *, c, barrier);
1205 rep_thread *t;
1206 for (t = ptr->head; t != 0; t = t->next)
1207 rep_MARKVAL (rep_VAL (t));
1208 for (t = ptr->susp_head; t != 0; t = t->next)
1209 rep_MARKVAL (rep_VAL (t));
1210 rep_MARKVAL (rep_VAL (ptr->active));
1211 }
1212 for (roots = c->gc_roots;
1213 roots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom);
1214 roots = FIXUP(rep_GC_root *, c, roots)->next)
1215 {
1216 repv *ptr = FIXUP(rep_GC_root *, c, roots)->ptr;
1217 rep_MARKVAL (*FIXUP(repv *, c, ptr));
1218 }
1219 for (nroots = c->gc_n_roots;
1220 nroots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom);
1221 nroots = FIXUP(rep_GC_n_roots *, c, nroots)->next)
1222 {
1223 repv *ptr = FIXUP(repv *, c, FIXUP(rep_GC_n_roots *, c, nroots)->first);
1224 int n = FIXUP(rep_GC_n_roots *, c, nroots)->count, i;
1225 for (i = 0; i < n; i++)
1226 rep_MARKVAL (ptr[i]);
1227 }
1228 for (calls = c->call_stack;
1229 calls != 0 && !SP_OLDER_P ((char *) calls, c->stack_bottom);
1230 calls = FIXUP(struct rep_Call *, c, calls)->next)
1231 {
1232 struct rep_Call *lc = FIXUP(struct rep_Call *, c, calls);
1233 rep_MARKVAL(lc->fun);
1234 rep_MARKVAL(lc->args);
1235 rep_MARKVAL(lc->current_form);
1236 rep_MARKVAL(lc->saved_env);
1237 rep_MARKVAL(lc->saved_structure);
1238 }
1239 for (matches = c->regexp_data;
1240 matches != 0 && !SP_OLDER_P ((char *) matches, c->stack_bottom);
1241 matches = FIXUP(struct rep_saved_regexp_data *, c, matches)->next)
1242 {
1243 struct rep_saved_regexp_data *sd
1244 = FIXUP(struct rep_saved_regexp_data *, c, matches);
1245 assert (sd->type == rep_reg_obj || sd->type == rep_reg_string);
1246 if(sd->type == rep_reg_obj)
1247 {
1248 int i;
1249 for(i = 0; i < rep_NSUBEXP; i++)
1250 {
1251 rep_MARKVAL(sd->matches.obj.startp[i]);
1252 rep_MARKVAL(sd->matches.obj.endp[i]);
1253 }
1254 }
1255 rep_MARKVAL(sd->data);
1256 }
1257 }
1258
1259 static void
mark_all(void)1260 mark_all (void)
1261 {
1262 rep_barrier *ptr;
1263 for (ptr = barriers; ptr != 0; ptr = ptr->next)
1264 {
1265 rep_thread *t;
1266 for (t = ptr->head; t != 0; t = t->next)
1267 rep_MARKVAL (rep_VAL (t));
1268 for (t = ptr->susp_head; t != 0; t = t->next)
1269 rep_MARKVAL (rep_VAL (t));
1270 rep_MARKVAL (rep_VAL (ptr->active));
1271 }
1272 }
1273
1274 static void
sweep_cont(void)1275 sweep_cont (void)
1276 {
1277 rep_continuation *c = continuations;
1278 continuations = 0;
1279 while (c)
1280 {
1281 rep_continuation *next = c->next;
1282 if (!rep_GC_CELL_MARKEDP (rep_VAL (c)))
1283 {
1284 rep_free (c->stack_copy);
1285 rep_FREE_CELL (c);
1286 }
1287 else
1288 {
1289 rep_GC_CLR_CELL (rep_VAL (c));
1290 c->next = continuations;
1291 continuations = c;
1292 }
1293 c = next;
1294 }
1295 }
1296
1297 static void
print_cont(repv stream,repv obj)1298 print_cont (repv stream, repv obj)
1299 {
1300 rep_stream_puts (stream, "#<continuation>", -1, rep_FALSE);
1301 }
1302
1303 static int
continuation_type(void)1304 continuation_type (void)
1305 {
1306 static int type;
1307
1308 if (type == 0)
1309 {
1310 type = rep_register_new_type ("continuation",
1311 rep_ptr_cmp, print_cont, print_cont,
1312 sweep_cont, mark_cont, mark_all,
1313 0, 0, 0, 0, 0, 0);
1314 }
1315
1316 return type;
1317 }
1318
1319 static void
mark_thread(repv obj)1320 mark_thread (repv obj)
1321 {
1322 rep_MARKVAL (rep_VAL (THREAD (obj)->cont));
1323 rep_MARKVAL (THREAD (obj)->env);
1324 rep_MARKVAL (THREAD (obj)->structure);
1325 rep_MARKVAL (THREAD (obj)->name);
1326 rep_MARKVAL (THREAD (obj)->exit_val);
1327 }
1328
1329 static void
sweep_thread(void)1330 sweep_thread (void)
1331 {
1332 rep_thread *t = threads;
1333 threads = 0;
1334 while (t)
1335 {
1336 rep_thread *next = t->next_alloc;
1337 if (!rep_GC_CELL_MARKEDP (rep_VAL (t)))
1338 rep_FREE_CELL (t);
1339 else
1340 {
1341 rep_GC_CLR_CELL (rep_VAL (t));
1342 t->next_alloc = threads;
1343 threads = t;
1344 }
1345 t = next;
1346 }
1347 }
1348
1349 static void
print_thread(repv stream,repv obj)1350 print_thread (repv stream, repv obj)
1351 {
1352 rep_stream_puts (stream, "#<thread", -1, rep_FALSE);
1353 if (rep_STRINGP (THREAD (obj)->name))
1354 {
1355 rep_stream_putc (stream, ' ');
1356 rep_stream_puts (stream, rep_STR (THREAD (obj)->name), -1, rep_FALSE);
1357 }
1358 rep_stream_putc (stream, '>');
1359 }
1360
1361 static int
thread_type(void)1362 thread_type (void)
1363 {
1364 static int type;
1365
1366 if (type == 0)
1367 {
1368 type = rep_register_new_type ("thread", rep_ptr_cmp,
1369 print_thread, print_thread,
1370 sweep_thread, mark_thread,
1371 0, 0, 0, 0, 0, 0, 0);
1372 }
1373
1374 return type;
1375 }
1376
1377 #else /* WITH_CONTINUATIONS */
1378
1379 repv
rep_call_with_barrier(repv (* callback)(repv),repv arg,rep_bool closed,void (* in)(void *),void (* out)(void *),void * data)1380 rep_call_with_barrier (repv (*callback)(repv), repv arg,
1381 rep_bool closed, void (*in)(void *),
1382 void (*out)(void *), void *data)
1383 {
1384 return callback (arg);
1385 }
1386
1387 DEFSTRING (ccc_missing, "call/cc was not included in this system");
1388
1389 static repv
call_cc_missing(void)1390 call_cc_missing (void)
1391 {
1392 return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&ccc_missing)));
1393 }
1394
1395
1396 DEFUN ("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1)
1397 {
1398 return call_cc_missing ();
1399 }
1400
1401 DEFUN("continuation-callable-p", Fcontinuation_callable_p,
1402 Scontinuation_callable_p, (repv cont), rep_Subr1)
1403 {
1404 return rep_signal_arg_error (cont, 1);
1405 }
1406
1407 unsigned long
rep_max_sleep_for(void)1408 rep_max_sleep_for (void)
1409 {
1410 return UINT_MAX;
1411 }
1412
1413 #endif /* !WITH_CONTINUATIONS */
1414
1415
1416 /* misc lisp functions */
1417
1418 /* Bind one object, returning the handle to later unbind by. */
1419 static repv
bind_object(repv obj)1420 bind_object(repv obj)
1421 {
1422 rep_type *t = rep_get_data_type(rep_TYPE(obj));
1423 if (t->bind != 0)
1424 return t->bind(obj);
1425 else
1426 return Qnil;
1427 }
1428
1429 static void
unbind_object(repv handle)1430 unbind_object (repv handle)
1431 {
1432 repv obj;
1433 rep_type *t;
1434 if (handle == Qnil)
1435 return;
1436 else if (rep_CONSP (handle))
1437 obj = rep_CAR (handle);
1438 else
1439 obj = handle;
1440 t = rep_get_data_type (rep_TYPE (obj));
1441 if (t->unbind != 0)
1442 t->unbind(handle);
1443 }
1444
1445 static void
call_with_inwards(void * data_)1446 call_with_inwards (void *data_)
1447 {
1448 repv *data = data_;
1449 if (data[0] != rep_NULL)
1450 data[1] = bind_object (data[0]);
1451 else
1452 data[1] = rep_NULL;
1453 }
1454
1455 static void
call_with_outwards(void * data_)1456 call_with_outwards (void *data_)
1457 {
1458 repv *data = data_;
1459 if (data[1] != rep_NULL)
1460 {
1461 unbind_object (data[1]);
1462 data[1] = rep_NULL;
1463 }
1464 }
1465
1466 DEFUN("call-with-object", Fcall_with_object,
1467 Scall_with_object, (repv arg, repv thunk), rep_Subr2) /*
1468 ::doc:rep.lang.interpreter#call-with-object::
1469 call-with-object ARG THUNK
1470
1471 Call the zero-parameter function THUNK, with object ARG temporarily
1472 `bound' (a type-specific operation, usually to make ARG `active' in
1473 some way). When THUNK returns ARG is unbound. The value returned by
1474 THUNK is then returned.
1475
1476 If THUNK is ever left due to a continuation being invoked, ARG will be
1477 unbound. If THUNK is subsequently reentered, ARG will be rebound.
1478 ::end:: */
1479 {
1480 repv data[2]; /* { ARG, HANDLE } */
1481 data[0] = arg;
1482 data[1] = bind_object(data[0]);
1483 if (data[1] != rep_NULL)
1484 {
1485 repv ret;
1486 rep_GC_n_roots gc_data;
1487 rep_PUSHGCN (gc_data, data, 2);
1488 ret = rep_call_with_barrier (rep_call_lisp0, thunk,
1489 rep_FALSE, call_with_inwards,
1490 call_with_outwards, data);
1491 unbind_object (data[1]);
1492 rep_POPGCN;
1493 return ret;
1494 }
1495 else
1496 return rep_NULL;
1497 }
1498
1499 DEFUN("call-with-dynamic-root", Fcall_with_dynamic_root,
1500 Scall_with_dynamic_root, (repv thunk), rep_Subr1) /*
1501 ::doc:rep.lang.interpreter#call-with-dynamic-root::
1502 call-with-dynamic-root THUNK
1503
1504 Call the zero-parameter function THUNK, as the root of a new execution
1505 environment. This means that the continuation of THUNK will always be
1506 reached once, and once only. Any continuations above the new root may
1507 not be invoked from inside the root.
1508 ::end:: */
1509 {
1510 return rep_call_with_barrier (rep_call_lisp0, thunk, rep_TRUE, 0, 0, 0);
1511 }
1512
1513 static void
call_in(void * data_)1514 call_in (void *data_)
1515 {
1516 repv *data = data_;
1517 if (data[0] != Qnil)
1518 rep_call_lisp0 (data[0]);
1519 }
1520
1521 static void
call_out(void * data_)1522 call_out (void *data_)
1523 {
1524 repv *data = data_;
1525 if (data[1] != Qnil)
1526 rep_call_lisp0 (data[1]);
1527 }
1528
1529 DEFUN("call-with-barrier", Fcall_with_barrier, Scall_with_barrier,
1530 (repv thunk, repv closed, repv in, repv out), rep_Subr4) /*
1531 ::doc:rep.lang.interpreter#call-with-barrier::
1532 call-with-barrier THUNK CLOSED [IN-THUNK] [OUT-THUNK]
1533
1534 Call THUNK inside a new execution environment. If CLOSED is non-`nil'
1535 then the new environment will be exited exactly once (i.e.
1536 continuations may not pass through it).
1537
1538 Alternatively, if CLOSED is `nil' then the environment is said to be
1539 `open' and continuations may cause control to flow into and out of the
1540 new environment. As this happens one of IN-THUNK or OUT-THUNK will be
1541 called (if defined).
1542
1543 The value of this function is the value returned by THUNK.
1544 ::end:: */
1545 {
1546 repv thunks[2], ret;
1547 rep_GC_n_roots gc_thunks;
1548 thunks[0] = in;
1549 thunks[1] = out;
1550 rep_PUSHGCN (gc_thunks, thunks, 2);
1551 ret = rep_call_with_barrier (rep_call_lisp0, thunk,
1552 closed == Qnil ? rep_FALSE : rep_TRUE,
1553 call_in, call_out, thunks);
1554 rep_POPGCN;
1555 return ret;
1556 }
1557
1558 DEFUN("make-thread", Fmake_thread, Smake_thread, (repv thunk, repv name), rep_Subr2) /*
1559 ::doc:rep.threads#make-thread::
1560 make-thread THUNK [NAME]
1561
1562 Create and return an object representing a new thread of execution. The
1563 new thread will begin by calling THUNK, a function with zero
1564 parameters.
1565 ::end:: */
1566 {
1567 #ifdef WITH_CONTINUATIONS
1568 return rep_VAL (make_thread (thunk, name, rep_FALSE));
1569 #else
1570 return call_cc_missing ();
1571 #endif
1572 }
1573
1574 DEFUN("make-suspended-thread", Fmake_suspended_thread, Smake_suspended_thread,
1575 (repv thunk, repv name), rep_Subr2) /*
1576 ::doc:rep.threads#make-suspended-thread::
1577 make-suspended-thread THUNK [NAME]
1578
1579 Identical to `make-thread', except that the created thread will be
1580 immediately put in the suspended state.
1581 ::end:: */
1582 {
1583 #ifdef WITH_CONTINUATIONS
1584 return rep_VAL (make_thread (thunk, name, rep_TRUE));
1585 #else
1586 return call_cc_missing ();
1587 #endif
1588 }
1589
1590 DEFUN("thread-yield", Fthread_yield, Sthread_yield, (void), rep_Subr0) /*
1591 ::doc:rep.threads#thread-yield::
1592 thread-yield
1593
1594 Pass control away from the current thread if other threads are waiting
1595 to run.
1596 ::end:: */
1597 {
1598 #ifdef WITH_CONTINUATIONS
1599 return thread_yield () ? Qt : Qnil;
1600 #else
1601 return Qnil;
1602 #endif
1603 }
1604
1605 DEFUN("thread-delete", Fthread_delete, Sthread_delete, (repv th), rep_Subr1) /*
1606 ::doc:rep.threads#thread-delete::
1607 thread-delete [THREAD]
1608
1609 Mark THREAD (or the current thread), as being deleted. It will not be
1610 switched to in the future. If the current thread is deleted, control
1611 will be passed to the next runnable thread. Deleting the last runnable
1612 thread results forces the containing dynamic root to be closed.
1613 ::end:: */
1614 {
1615 #ifdef WITH_CONTINUATIONS
1616 if (th == Qnil)
1617 th = Fcurrent_thread (Qnil);
1618 rep_DECLARE1 (th, THREADP);
1619 thread_delete (THREAD (th));
1620 return Qnil;
1621 #else
1622 return rep_signal_arg_error (th, 1);
1623 #endif
1624 }
1625
1626 DEFUN("thread-suspend", Fthread_suspend,
1627 Sthread_suspend, (repv th, repv msecs), rep_Subr2) /*
1628 ::doc:rep.threads#thread-suspend::
1629 thread-suspend [THREAD] [MSECS]
1630
1631 Mark THREAD (or the current thread) as being suspended. It will not be
1632 selected until it has this status removed. Suspending the current
1633 thread will pass control to the next runnable thread. If there are no
1634 runnable threads, then sleep until the next thread becomes runnable.
1635
1636 Returns true if the timeout was reached.
1637 ::end:: */
1638 {
1639 #ifdef WITH_CONTINUATIONS
1640 long timeout;
1641 repv no_timeout;
1642 if (th == Qnil)
1643 th = Fcurrent_thread (Qnil);
1644 rep_DECLARE1 (th, THREADP);
1645 rep_DECLARE2_OPT (msecs, rep_NUMERICP);
1646 timeout = (msecs == Qnil) ? 1 : rep_get_long_int (msecs);
1647 thread_suspend (THREAD (th), timeout, 0, 0);
1648 no_timeout = THREAD (th)->exit_val;
1649 THREAD (th)->exit_val = rep_NULL;
1650 return no_timeout == Qnil ? Qt : Qnil;
1651 #else
1652 return rep_signal_arg_error (th, 1);
1653 #endif
1654 }
1655
1656 #ifdef WITH_CONTINUATIONS
1657 static rep_bool
thread_join_poller(rep_thread * t,void * arg)1658 thread_join_poller (rep_thread *t, void *arg)
1659 {
1660 rep_thread *th = arg;
1661 return (th->car & TF_EXITED) ? rep_TRUE : rep_FALSE;
1662 }
1663 #endif
1664
1665 DEFUN("thread-join", Fthread_join,
1666 Sthread_join, (repv th, repv msecs, repv def), rep_Subr3) /*
1667 ::doc:rep.threads#thread-join::
1668 thread-join THREAD [MSECS] [DEFAULT-VALUE]
1669
1670 Suspend the current thread until THREAD has exited, or MSECS
1671 milliseconds have passed. If THREAD exits normally, return the value of
1672 the last form it evaluated, else return DEFAULT-VALUE.
1673
1674 It is an error to call thread-join on a THREAD that is not a member of
1675 current dynamic root.
1676 ::end:: */
1677 {
1678 #ifdef WITH_CONTINUATIONS
1679 repv self = Fcurrent_thread (Qnil);
1680 rep_DECLARE (1, th, XTHREADP (th) && th != self
1681 && THREAD (th)->cont->root == root_barrier);
1682 if (THREADP (self))
1683 {
1684 rep_GC_root gc_th;
1685 rep_PUSHGC (gc_th, th);
1686 rep_DECLARE2_OPT (msecs, rep_NUMERICP);
1687 thread_suspend (THREAD (self),
1688 rep_get_long_int (msecs),
1689 thread_join_poller, THREAD (th));
1690 THREAD (self)->exit_val = rep_NULL;
1691 rep_POPGC;
1692 if ((THREAD (th)->car & TF_EXITED) && THREAD (th)->exit_val)
1693 return THREAD (th)->exit_val;
1694 }
1695 return def;
1696 #else
1697 return rep_signal_arg_error (th, 1);
1698 #endif
1699 }
1700
1701 DEFUN("thread-wake", Fthread_wake, Sthread_wake, (repv th), rep_Subr1) /*
1702 ::doc:rep.threads#thread-wake::
1703 thread-wake [THREAD]
1704
1705 If THREAD (or the current thread) is currently suspended, mark it as
1706 being runnable once more.
1707 ::end:: */
1708 {
1709 #ifdef WITH_CONTINUATIONS
1710 if (th == Qnil)
1711 th = Fcurrent_thread (Qnil);
1712 rep_DECLARE1 (th, THREADP);
1713 THREAD (th)->exit_val = Qt; /* signals timeout not reached */
1714 thread_wake (THREAD (th));
1715 return Qnil;
1716 #else
1717 return rep_signal_arg_error (th, 1);
1718 #endif
1719 }
1720
1721 DEFUN("threadp", Fthreadp, Sthreadp, (repv arg), rep_Subr1) /*
1722 ::doc:rep.threads#threadp::
1723 threadp ARG
1724
1725 Return `t' if ARG is a thread object.
1726 ::end:: */
1727 {
1728 #ifdef WITH_CONTINUATIONS
1729 return XTHREADP (arg) ? Qt : Qnil;
1730 #else
1731 return Qnil;
1732 #endif
1733 }
1734
1735 DEFUN("thread-suspended-p", Fthread_suspended_p,
1736 Sthread_suspended_p, (repv th), rep_Subr1) /*
1737 ::doc:rep.threads#thread-suspended-p::
1738 thread-suspended-p THREAD
1739
1740 Return `t' if THREAD is currently suspended from running.
1741 ::end:: */
1742 {
1743 #ifdef WITH_CONTINUATIONS
1744 rep_DECLARE1 (th, THREADP);
1745 return (THREAD (th)->car & TF_SUSPENDED) ? Qt : Qnil;
1746 #else
1747 return rep_signal_arg_error (th, 1);
1748 #endif
1749 }
1750
1751 DEFUN("thread-exited-p", Fthread_exited_p,
1752 Sthread_exited_p, (repv th), rep_Subr1) /*
1753 ::doc:rep.threads#thread-exited-p::
1754 thread-exited-p THREAD
1755
1756 Return `t' if THREAD has exited.
1757 ::end:: */
1758 {
1759 #ifdef WITH_CONTINUATIONS
1760 rep_DECLARE1 (th, XTHREADP);
1761 return (THREAD (th)->car & TF_EXITED) ? Qt : Qnil;
1762 #else
1763 return rep_signal_arg_error (th, 1);
1764 #endif
1765 }
1766
1767 DEFUN("current-thread", Fcurrent_thread,
1768 Scurrent_thread, (repv depth), rep_Subr1) /*
1769 ::doc:rep.threads#current-thread::
1770 current-thread [DEPTH]
1771
1772 Return the currently executing thread.
1773 ::end:: */
1774 {
1775 #ifdef WITH_CONTINUATIONS
1776 rep_barrier *root;
1777
1778 rep_DECLARE1_OPT (depth, rep_INTP);
1779 if (depth == Qnil)
1780 depth = rep_MAKE_INT (0);
1781
1782 if (depth == rep_MAKE_INT (0))
1783 ensure_default_thread ();
1784
1785 root = get_dynamic_root (rep_INT (depth));
1786 if (root == 0)
1787 return Qnil;
1788 else
1789 return (root->active) ? rep_VAL (root->active) : Qnil;
1790 #else
1791 return Qnil;
1792 #endif
1793 }
1794
1795 DEFUN("all-threads", Fall_threads, Sall_threads, (repv depth), rep_Subr1) /*
1796 ::doc:rep.threads#all-threads::
1797 all-threads [DEPTH]
1798
1799 Return a list of all threads.
1800 ::end:: */
1801 {
1802 #ifdef WITH_CONTINUATIONS
1803 rep_barrier *root;
1804
1805 rep_DECLARE1_OPT (depth, rep_INTP);
1806 if (depth == Qnil)
1807 depth = rep_MAKE_INT (0);
1808
1809 if (depth == rep_MAKE_INT (0))
1810 ensure_default_thread ();
1811
1812 root = get_dynamic_root (rep_INT (depth));
1813 if (root == 0)
1814 return Qnil;
1815 else
1816 {
1817 repv out = Qnil;
1818 rep_thread *ptr;
1819 for (ptr = root->susp_tail; ptr != 0; ptr = ptr->pred)
1820 out = Fcons (rep_VAL (ptr), out);
1821 for (ptr = root->tail; ptr != 0; ptr = ptr->pred)
1822 out = Fcons (rep_VAL (ptr), out);
1823 return out;
1824 }
1825 #else
1826 return Qnil;
1827 #endif
1828 }
1829
1830 DEFUN("thread-forbid", Fthread_forbid, Sthread_forbid, (void), rep_Subr0) /*
1831 ::doc:rep.threads#thread-forbid::
1832 thread-forbid
1833
1834 Increment the thread preemption lock. When greather than zero all
1835 preemption of threads is disabled. Returns `t' if preemption is blocked
1836 as this function returns.
1837 ::end:: */
1838 {
1839 rep_FORBID;
1840 return rep_PREEMPTABLE_P ? Qnil : Qt;
1841 }
1842
1843 DEFUN("thread-permit", Fthread_permit, Sthread_permit, (void), rep_Subr0) /*
1844 ::doc:rep.threads#thread-permit::
1845 thread-permit
1846
1847 Decrement the thread preemption lock. When greather than zero all
1848 preemption of threads is disabled. Returns `t' if preemption is blocked
1849 as this function returns.
1850 ::end:: */
1851 {
1852 rep_PERMIT;
1853 return rep_PREEMPTABLE_P ? Qnil : Qt;
1854 }
1855
1856 DEFUN("thread-name", Fthread_name, Sthread_name, (repv th), rep_Subr1) /*
1857 ::doc:rep.threads#thread-name:
1858 thread-name THREAD
1859
1860 Return the name of the thread THREAD.
1861 ::end:: */
1862 {
1863 #ifdef WITH_CONTINUATIONS
1864 rep_DECLARE1 (th, XTHREADP);
1865 return THREAD (th)->name;
1866 #else
1867 return rep_signal_arg_error (th, 1);
1868 #endif
1869 }
1870
1871
1872 /* dl hooks */
1873
1874 void
rep_continuations_init(void)1875 rep_continuations_init (void)
1876 {
1877 repv tem = rep_push_structure ("rep.lang.interpreter");
1878
1879 #ifdef WITH_CONTINUATIONS
1880 exit_barrier_cell = Fcons (Qnil, Qnil);
1881 rep_mark_static (&exit_barrier_cell);
1882 rep_INTERN(continuation);
1883 rep_ADD_INTERNAL_SUBR(Sprimitive_invoke_continuation);
1884 #endif
1885
1886 rep_ADD_SUBR(Scall_cc);
1887 rep_ADD_SUBR(Scontinuation_callable_p);
1888 rep_ADD_SUBR(Scall_with_object);
1889 rep_ADD_SUBR(Scall_with_dynamic_root);
1890 rep_ADD_SUBR(Scall_with_barrier);
1891 rep_pop_structure (tem);
1892
1893 tem = rep_push_structure ("rep.threads");
1894 rep_ADD_SUBR(Smake_thread);
1895 rep_ADD_SUBR(Smake_suspended_thread);
1896 rep_ADD_SUBR(Sthread_yield);
1897 rep_ADD_SUBR(Sthread_delete);
1898 rep_ADD_SUBR(Sthread_suspend);
1899 rep_ADD_SUBR(Sthread_join);
1900 rep_ADD_SUBR(Sthread_wake);
1901 rep_ADD_SUBR(Sthreadp);
1902 rep_ADD_SUBR(Sthread_suspended_p);
1903 rep_ADD_SUBR(Sthread_exited_p);
1904 rep_ADD_SUBR(Scurrent_thread);
1905 rep_ADD_SUBR(Sall_threads);
1906 rep_ADD_SUBR(Sthread_forbid);
1907 rep_ADD_SUBR(Sthread_permit);
1908 rep_ADD_SUBR(Sthread_name);
1909 rep_pop_structure (tem);
1910 }
1911