« back to all changes in this revision
Viewing changes to src/continuations.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Christian Marillat
- Date: 2001-11-13 15:06:22 UTC
- Revision ID: james.westby@ubuntu.com-20011113150622-vgmgmk6srj3kldr3
Tags: upstream-0.15.2
Import upstream version 0.15.2
- files added:
- doc
- intl
- lisp
- lisp/rep
- lisp/rep/data
- lisp/rep/i18n
- lisp/rep/io
- lisp/rep/io/file-handlers
- lisp/rep/io/file-handlers/remote
- lisp/rep/lang
- lisp/rep/mail
- lisp/rep/net
- lisp/rep/system
- lisp/rep/test
- lisp/rep/threads
- lisp/rep/util
- lisp/rep/vm
- lisp/rep/vm/compiler
- lisp/rep/www
- lisp/scheme
- lisp/unscheme
- man
- src
added
removed
src/continuations.c
1
/* continuations.c -- continuations, much stack hackery..
2
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
3
$Id: continuations.c,v 1.45 2001/09/16 00:29:40 jsh Exp $
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, 675 Mass Ave, Cambridge, MA 02139, 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
u_int closed : 1;
196
u_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 *
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
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 *
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
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 *
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
455
save_stack (rep_continuation *c)
456
{
457
size_t size;
458
459
FLUSH_REGISTER_WINDOWS;
460
461
#if defined (__GNUC__) && !defined (BROKEN_ALPHA_GCC)
462
c->stack_top = __builtin_frame_address (0);
463
#else
464
c->stack_top = (char *) &size;
465
#endif
466
467
#if STACK_DIRECTION < 0
468
size = c->stack_bottom - c->stack_top;
469
#else
470
size = c->stack_top - c->stack_bottom;
471
#endif
472
473
if (c->stack_copy != 0)
474
{
475
if (c->stack_size < size || (c->stack_size - size) > CONTIN_MAX_SLOP)
476
{
477
rep_free (c->stack_copy);
478
rep_data_after_gc -= c->stack_size;
479
c->stack_copy = 0;
480
}
481
}
482
483
if (c->stack_copy == 0)
484
{
485
c->stack_size = size;
486
c->stack_copy = rep_alloc (size);
487
rep_data_after_gc += size;
488
}
489
490
c->real_size = size;
491
#if STACK_DIRECTION < 0
492
memcpy (c->stack_copy, c->stack_top, c->real_size);
493
#else
494
memcpy (c->stack_copy, c->stack_bottom, c->real_size);
495
#endif
496
}
497
498
/* Make sure that the current frame has enough space under it to
499
hold the saved copy in C, then invoke the continuation */
500
static void
501
grow_stack_and_invoke (rep_continuation *c, char *water_mark)
502
{
503
volatile char growth[STACK_GROWTH];
504
505
/* if stack isn't large enough, recurse again */
506
507
#if STACK_DIRECTION < 0
508
if (water_mark >= c->stack_top)
509
grow_stack_and_invoke (c, (char *) growth + STACK_GROWTH);
510
#else
511
if (water_mark <= c->stack_top)
512
grow_stack_and_invoke (c, (char *) growth);
513
#endif
514
515
FLUSH_REGISTER_WINDOWS;
516
517
/* stack's big enough now, so reload the saved copy somewhere
518
below the current position. */
519
520
#if STACK_DIRECTION < 0
521
memcpy (c->stack_top, c->stack_copy, c->real_size);
522
#else
523
memcpy (c->stack_bottom, c->stack_copy, c->real_size);
524
#endif
525
526
longjmp (c->jmpbuf, 1);
527
}
528
529
static void
530
primitive_invoke_continuation (rep_continuation *c, repv ret)
531
{
532
char water_mark;
533
rep_barrier **dest_hist = 0, *dest_root = 0, *anc, *ptr;
534
int depth;
535
536
/* try to find a route from the current root barrier to the
537
root barrier of the continuation, without crossing any
538
closed barriers */
539
540
dest_root = FIXUP (rep_barrier *, c, c->barriers);
541
dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
542
depth = trace_barriers (c, dest_hist);
543
544
anc = common_ancestor (barriers, dest_hist, depth);
545
if (anc == 0)
546
{
547
DEFSTRING (unreachable, "unreachable continuation");
548
Fsignal (Qerror, rep_LIST_1 (rep_VAL (&unreachable)));
549
return;
550
}
551
552
/* Handle any `out' barrier functions */
553
for (ptr = barriers; ptr != anc; ptr = ptr->next)
554
{
555
DB (("invoke: outwards through %p (%d)\n", ptr, ptr->depth));
556
if (ptr->out != 0)
557
{
558
repv cont = rep_VAL (c);
559
rep_GC_root gc_cont, gc_ret;
560
rep_PUSHGC (gc_cont, cont);
561
rep_PUSHGC (gc_ret, ret);
562
ptr->out (ptr->data);
563
rep_POPGC; rep_POPGC;
564
}
565
}
566
567
/* save the return value and recurse up the stack until there's
568
room to invoke the continuation. Note that invoking this subr
569
will already have restored the original environment since the
570
call to Fmake_closure () will have saved its old state.. */
571
572
invoked_continuation = c;
573
invoked_continuation_ret = ret;
574
invoked_continuation_ancestor = anc;
575
576
DB (("invoke: calling continuation %p\n", c));
577
grow_stack_and_invoke (c, &water_mark);
578
}
579
580
/* The continuations passed in from Fcall_cc () are actually closures
581
around this subr. They have Qcontinuation bound to the primitive
582
continuation object in their lexical environment */
583
DEFUN("primitive-invoke-continuation", Fprimitive_invoke_continuation,
584
Sprimitive_invoke_continuation, (repv ret), rep_Subr1)
585
{
586
repv cont = Fsymbol_value (Qcontinuation, Qnil);
587
588
if (cont == rep_NULL || !rep_CONTINP(cont)
589
|| (rep_CONTIN(cont)->car & CF_INVALID))
590
{
591
DEFSTRING (invalid, "invalid continuation");
592
return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&invalid)));
593
}
594
595
primitive_invoke_continuation (rep_CONTIN (cont), ret);
596
return rep_NULL;
597
}
598
599
static repv
600
get_cont (repv arg)
601
{
602
return Fsymbol_value (Qcontinuation, Qnil);
603
}
604
605
DEFUN("continuation-callable-p", Fcontinuation_callable_p,
606
Scontinuation_callable_p, (repv cont), rep_Subr1) /*
607
::doc:rep.lang.interpreter#continuation-callable-p::
608
continuation-callable-p CONTINUATION
609
610
Returns `t' if the continuation object CONTINUATION from the current
611
execution point of the interpreter.
612
::end:: */
613
{
614
rep_continuation *c;
615
rep_barrier **dest_hist = 0, *dest_root = 0, *anc;
616
int depth;
617
618
rep_DECLARE1(cont, rep_FUNARGP);
619
cont = rep_call_with_closure (cont, get_cont, Qnil);
620
if (cont == rep_NULL)
621
return rep_NULL;
622
rep_DECLARE1(cont, rep_CONTINP);
623
c = rep_CONTIN (cont);
624
625
if (c->car & CF_INVALID)
626
return Qnil;
627
628
/* copied from above function */
629
630
dest_root = FIXUP (rep_barrier *, c, c->barriers);
631
dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
632
depth = trace_barriers (c, dest_hist);
633
634
anc = common_ancestor (barriers, dest_hist, depth);
635
return anc == 0 ? Qnil : Qt;
636
}
637
638
static repv
639
primitive_call_cc (repv (*callback)(rep_continuation *, void *), void *data,
640
rep_continuation *c)
641
{
642
struct rep_saved_regexp_data re_data;
643
repv ret;
644
645
if (root_barrier == 0)
646
{
647
DEFSTRING (no_root, "no dynamic root");
648
return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&no_root)));
649
}
650
651
if (c == 0)
652
{
653
c = rep_ALLOC_CELL (sizeof (rep_continuation));
654
rep_data_after_gc += sizeof (rep_continuation);
655
c->next = continuations;
656
continuations = c;
657
c->stack_copy = 0;
658
}
659
660
c->car = continuation_type ();
661
662
if (setjmp (c->jmpbuf))
663
{
664
/* back from call/cc */
665
rep_barrier *ancestor;
666
667
/* fish out the continuation (variable `c' may have been lost) */
668
c = invoked_continuation;
669
invoked_continuation = 0;
670
671
rep_lisp_depth = c->lisp_depth;
672
rep_single_step_flag = c->single_step;
673
rep_throw_value = c->throw_value;
674
memcpy (rep_blocked_ops, c->blocked_ops, sizeof (rep_blocked_ops));
675
rep_saved_matches = c->regexp_data;
676
rep_gc_n_roots_stack = c->gc_n_roots;
677
rep_gc_root_stack = c->gc_roots;
678
rep_special_bindings = c->special_bindings;
679
rep_call_stack = c->call_stack;
680
root_barrier = c->root;
681
barriers = c->barriers;
682
683
ret = invoked_continuation_ret;
684
invoked_continuation_ret = rep_NULL;
685
686
ancestor = invoked_continuation_ancestor;
687
invoked_continuation_ancestor = 0;
688
689
/* handle any `in' barrier functions */
690
if (barriers != 0)
691
{
692
int count = barriers->depth - (ancestor ? ancestor->depth : 0);
693
rep_barrier **hist = alloca (sizeof (rep_barrier *) * count);
694
rep_barrier *ptr;
695
int i = 0;
696
697
for (ptr = barriers; ptr != ancestor; ptr = ptr->next)
698
hist[i++] = ptr;
699
for (i = count - 1; i >= 0; i--)
700
{
701
ptr = hist[i];
702
DB (("invoke: inwards through %p (%d)\n", ptr, ptr->depth));
703
if (ptr->in != 0)
704
{
705
rep_GC_root gc_ret;
706
rep_PUSHGC (gc_ret, ret);
707
ptr->in (ptr->data);
708
rep_POPGC;
709
}
710
}
711
}
712
713
rep_pop_regexp_data ();
714
}
715
else
716
{
717
/* into call/cc */
718
719
rep_push_regexp_data (&re_data);
720
721
c->barriers = barriers;
722
c->root = root_barrier;
723
root_barrier->targeted = 1;
724
c->call_stack = rep_call_stack;
725
c->special_bindings = rep_special_bindings;
726
c->gc_roots = rep_gc_root_stack;
727
c->gc_n_roots = rep_gc_n_roots_stack;
728
c->regexp_data = rep_saved_matches;
729
memcpy (c->blocked_ops, rep_blocked_ops, sizeof (c->blocked_ops));
730
c->throw_value = rep_throw_value;
731
c->single_step = rep_single_step_flag;
732
c->lisp_depth = rep_lisp_depth;
733
734
c->stack_bottom = c->root->point;
735
save_stack (c);
736
737
DB (("call/cc: saved %p; real_size=%lu (%u)\n",
738
c, (u_long) c->real_size, rep_stack_bottom - c->stack_top));
739
740
ret = callback (c, data);
741
742
rep_pop_regexp_data ();
743
}
744
745
return ret;
746
}
747
748
static repv
749
inner_call_cc (rep_continuation *c, void *data)
750
{
751
repv proxy;
752
proxy = Fmake_closure (rep_VAL(&Sprimitive_invoke_continuation), Qnil);
753
rep_FUNARG(proxy)->env
754
= rep_add_binding_to_env (rep_FUNARG(proxy)->env,
755
Qcontinuation, rep_VAL(c));
756
return rep_call_lisp1 ((repv) data, proxy);
757
}
758
759
DEFUN("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1) /*
760
::doc:rep.lang.interpreter#call/cc::
761
call/cc FUNCTION
762
763
Invoke FUNCTION with a single parameter, the continuation function of
764
the current state of the interpreter. Subsequently calling the
765
continuation function (with an optional single argument) will pass
766
control immediately back to the statement following the call to the
767
`call/cc' function (even if that stack frame has since been exited).
768
::end:: */
769
{
770
return primitive_call_cc (inner_call_cc, (void *) fun, 0);
771
}
772
773
774
/* threads */
775
776
static inline void
777
thread_save_environ (rep_thread *t)
778
{
779
t->env = rep_env;
780
t->structure = rep_structure;
781
}
782
783
static inline void
784
thread_load_environ (rep_thread *t)
785
{
786
rep_env = t->env;
787
rep_structure = t->structure;
788
}
789
790
static void
791
enqueue_thread (rep_thread *t, rep_barrier *root)
792
{
793
assert (!(t->car & TF_EXITED));
794
if (!(t->car & TF_SUSPENDED))
795
{
796
t->pred = root->tail;
797
if (t->pred != 0)
798
t->pred->next = t;
799
if (root->head == 0)
800
root->head = t;
801
root->tail = t;
802
}
803
else
804
{
805
rep_thread *ptr = root->susp_head;
806
while (ptr != 0 && TV_LATER_P (&t->run_at, &ptr->run_at))
807
ptr = ptr->next;
808
if (ptr != 0)
809
{
810
t->pred = ptr->pred;
811
if (ptr->pred != 0)
812
ptr->pred->next = t;
813
else
814
root->susp_head = t;
815
ptr->pred = t;
816
t->next = ptr;
817
}
818
else
819
{
820
t->pred = root->susp_tail;
821
if (t->pred != 0)
822
t->pred->next = t;
823
if (root->susp_head == 0)
824
root->susp_head = t;
825
root->susp_tail = t;
826
}
827
}
828
}
829
830
static void
831
unlink_thread (rep_thread *t)
832
{
833
rep_barrier *root = t->cont->root;
834
835
if (t->pred != 0)
836
t->pred->next = t->next;
837
if (t->next != 0)
838
t->next->pred = t->pred;
839
840
if (!(t->car & TF_SUSPENDED))
841
{
842
if (root->head == t)
843
root->head = t->next;
844
if (root->tail == t)
845
root->tail = t->pred;
846
}
847
else
848
{
849
if (root->susp_head == t)
850
root->susp_head = t->next;
851
if (root->susp_tail == t)
852
root->susp_tail = t->pred;
853
}
854
t->next = t->pred = 0;
855
}
856
857
static void
858
thread_wake (rep_thread *t)
859
{
860
rep_barrier *root = t->cont->root;
861
assert (t->car & TF_SUSPENDED);
862
assert (!(t->car & TF_EXITED));
863
864
unlink_thread (t);
865
t->car &= ~TF_SUSPENDED;
866
enqueue_thread (t, root);
867
}
868
869
static rep_bool
870
poll_threads (rep_barrier *root)
871
{
872
rep_bool woke_any = rep_FALSE;
873
rep_thread *t, *next;
874
for (t = root->susp_head; t != 0; t = next)
875
{
876
next = t->next;
877
if (t->poll && t->poll (t, t->poll_arg))
878
{
879
thread_wake (t);
880
woke_any = rep_TRUE;
881
}
882
}
883
return woke_any;
884
}
885
886
static repv
887
inner_thread_invoke (rep_continuation *c, void *data)
888
{
889
rep_thread *t = data;
890
t->cont = c;
891
rep_thread_lock = root_barrier->head->lock;
892
DB (("invoking thread %p\n", root_barrier->head));
893
thread_load_environ (root_barrier->head);
894
primitive_invoke_continuation (root_barrier->head->cont, Qnil);
895
return rep_NULL;
896
}
897
898
static void
899
thread_invoke (void)
900
{
901
again:
902
if (root_barrier == 0)
903
return;
904
905
if (root_barrier->head != 0)
906
{
907
rep_thread *active = root_barrier->active;
908
assert (root_barrier->head != 0);
909
root_barrier->active = root_barrier->head;
910
if (active != 0)
911
{
912
/* save the continuation of this thread,
913
then invoke the next thread */
914
active->lock = rep_thread_lock;
915
thread_save_environ (active);
916
primitive_call_cc (inner_thread_invoke, active, active->cont);
917
}
918
else
919
{
920
rep_thread_lock = root_barrier->head->lock;
921
DB (("invoking thread %p\n", root_barrier->head));
922
thread_load_environ (root_barrier->head);
923
primitive_invoke_continuation (root_barrier->head->cont, Qnil);
924
}
925
}
926
else
927
{
928
/* No thread to run. If no suspended threads return from the
929
root barrier. Else sleep.. */
930
if (root_barrier->susp_head == 0)
931
{
932
root_barrier->active = 0;
933
assert (rep_throw_value != exit_barrier_cell);
934
rep_CDR (exit_barrier_cell) = rep_throw_value;
935
rep_throw_value = exit_barrier_cell;
936
DB (("no more threads, throwing to root..\n"));
937
return;
938
}
939
else if (poll_threads (root_barrier))
940
{
941
/* something woke */
942
goto again;
943
}
944
else
945
{
946
rep_thread *b = root_barrier->susp_head;
947
struct timeval now;
948
gettimeofday (&now, 0);
949
DB (("no more threads, sleeping..\n"));
950
if (TV_LATER_P (&b->run_at, &now))
951
{
952
struct timeval delta;
953
delta.tv_sec = b->run_at.tv_sec - now.tv_sec;
954
delta.tv_usec = b->run_at.tv_usec - now.tv_usec;
955
while (delta.tv_usec < 0)
956
{
957
delta.tv_usec += 1000000;
958
delta.tv_sec--;
959
}
960
rep_sleep_for (delta.tv_sec, delta.tv_usec / 1000);
961
}
962
DB (("..waking thread %p\n", b));
963
thread_wake (b);
964
goto again;
965
}
966
}
967
}
968
969
static void
970
thread_delete (rep_thread *t)
971
{
972
rep_barrier *root = t->cont->root;
973
rep_thread *active = root->head;
974
975
unlink_thread (t);
976
t->car |= TF_EXITED;
977
if (active == t)
978
thread_invoke ();
979
}
980
981
static repv
982
inner_make_thread (rep_continuation *c, void *data)
983
{
984
rep_thread *t = data;
985
t->cont = c;
986
enqueue_thread (t, t->cont->root);
987
return -1;
988
}
989
990
static rep_thread *
991
new_thread (repv name)
992
{
993
rep_thread *t = rep_ALLOC_CELL (sizeof (rep_thread));
994
rep_data_after_gc += sizeof (rep_thread);
995
memset (t, 0, sizeof (rep_thread));
996
t->car = thread_type ();
997
t->name = name;
998
t->poll = 0;
999
t->poll_arg = 0;
1000
t->exit_val = rep_NULL;
1001
t->next_alloc = threads;
1002
threads = t;
1003
return t;
1004
}
1005
1006
static void
1007
ensure_default_thread (void)
1008
{
1009
if (root_barrier->active == 0)
1010
{
1011
/* entering threaded execution. make the default thread */
1012
rep_thread *x = new_thread (Qnil);
1013
thread_save_environ (x);
1014
/* this continuation will never get called,
1015
but it simplifies things.. */
1016
if (primitive_call_cc (inner_make_thread, x, 0) != -1)
1017
abort ();
1018
root_barrier->active = x;
1019
}
1020
}
1021
1022
static rep_thread *
1023
make_thread (repv thunk, repv name, rep_bool suspended)
1024
{
1025
repv ret;
1026
rep_GC_root gc_thunk;
1027
rep_thread *t;
1028
1029
if (root_barrier == 0)
1030
return 0;
1031
1032
t = new_thread (name);
1033
if (suspended)
1034
t->car |= TF_SUSPENDED;
1035
thread_save_environ (t);
1036
1037
ensure_default_thread ();
1038
1039
rep_PUSHGC (gc_thunk, thunk);
1040
ret = primitive_call_cc (inner_make_thread, t, 0);
1041
rep_POPGC;
1042
if (ret == -1)
1043
return t;
1044
else
1045
{
1046
ret = rep_call_lisp0 (thunk);
1047
t->car |= TF_EXITED;
1048
if (ret != rep_NULL)
1049
{
1050
t->exit_val = ret;
1051
thread_delete (t);
1052
assert (rep_throw_value == exit_barrier_cell);
1053
}
1054
else
1055
{
1056
/* exited with a throw, throw out of the dynamic root */
1057
rep_CDR (exit_barrier_cell) = rep_throw_value;
1058
rep_throw_value = exit_barrier_cell;
1059
}
1060
return 0;
1061
}
1062
}
1063
1064
static rep_bool
1065
thread_yield (void)
1066
{
1067
struct timeval now;
1068
rep_thread *ptr, *next;
1069
rep_thread *old_head;
1070
1071
if (root_barrier == 0)
1072
return rep_FALSE;
1073
1074
old_head = root_barrier->head;
1075
rep_pending_thread_yield = rep_FALSE;
1076
if (root_barrier->head && root_barrier->head->next)
1077
{
1078
rep_thread *old = root_barrier->head;
1079
if (old->pred != 0)
1080
old->pred->next = old->next;
1081
if (old->next != 0)
1082
old->next->pred = old->pred;
1083
root_barrier->head = old->next;
1084
old->next = 0;
1085
old->pred = root_barrier->tail;
1086
old->pred->next = old;
1087
root_barrier->tail = old;
1088
}
1089
1090
/* check suspend queue for threads that need waking */
1091
1092
if (root_barrier->susp_head != 0)
1093
gettimeofday (&now, 0);
1094
for (ptr = root_barrier->susp_head; ptr != 0; ptr = next)
1095
{
1096
next = ptr->next;
1097
if (TV_LATER_P (&now, &ptr->run_at)
1098
|| (ptr->poll && ptr->poll (ptr, ptr->poll_arg)))
1099
{
1100
thread_wake (ptr);
1101
}
1102
}
1103
1104
if (root_barrier->head != old_head)
1105
{
1106
thread_invoke ();
1107
return rep_TRUE;
1108
}
1109
else
1110
return rep_FALSE;
1111
}
1112
1113
static void
1114
thread_suspend (rep_thread *t, u_long msecs,
1115
rep_bool (*poll)(rep_thread *t, void *arg), void *poll_arg)
1116
{
1117
rep_barrier *root = t->cont->root;
1118
assert (!(t->car & TF_SUSPENDED));
1119
assert (!(t->car & TF_EXITED));
1120
1121
unlink_thread (t);
1122
t->car |= TF_SUSPENDED;
1123
if (msecs == 0)
1124
{
1125
/* XXX assumes twos-complement representation.. but Solaris
1126
XXX has a weird struct timeval.. */
1127
t->run_at.tv_sec = ~0UL >> 1;
1128
t->run_at.tv_usec = ~0UL >> 1;
1129
}
1130
else
1131
{
1132
gettimeofday (&t->run_at, 0);
1133
t->run_at.tv_sec += (msecs / 1000);
1134
t->run_at.tv_usec += (msecs % 1000) * 1000;
1135
if (t->run_at.tv_usec > 1000000)
1136
{
1137
t->run_at.tv_sec += t->run_at.tv_usec / 1000000;
1138
t->run_at.tv_usec = t->run_at.tv_usec % 1000000;
1139
}
1140
}
1141
t->poll = poll;
1142
t->poll_arg = poll_arg;
1143
t->exit_val = Qnil;
1144
enqueue_thread (t, root);
1145
if (root_barrier->active == t)
1146
thread_invoke ();
1147
}
1148
1149
u_long
1150
rep_max_sleep_for (void)
1151
{
1152
rep_barrier *root = root_barrier;
1153
if (root == 0 || root->active == 0)
1154
{
1155
/* not using threads, sleep as long as you like..
1156
XXX grr.. using ULONG_MAX doesn't work on solaris*/
1157
return UINT_MAX;
1158
}
1159
else if (root->head != 0 && root->head->next != 0)
1160
{
1161
/* other threads ready to run, don't sleep */
1162
return 0;
1163
}
1164
else if (root->susp_head != 0)
1165
{
1166
/* other threads sleeping, how long until the first wakes? */
1167
/* XXX ignores polling */
1168
struct timeval now;
1169
long msecs;
1170
gettimeofday (&now, 0);
1171
msecs = ((root->susp_head->run_at.tv_sec - now.tv_sec) * 1000
1172
+ (root->susp_head->run_at.tv_usec - now.tv_usec) / 1000);
1173
return MAX (msecs, 0);
1174
}
1175
else
1176
{
1177
/* whatever.. */
1178
return UINT_MAX;
1179
}
1180
}
1181
1182
1183
/* type hooks */
1184
1185
static void
1186
mark_cont (repv obj)
1187
{
1188
rep_GC_root *roots;
1189
rep_GC_n_roots *nroots;
1190
struct rep_Call *calls;
1191
struct rep_saved_regexp_data *matches;
1192
rep_barrier *barrier;
1193
1194
rep_continuation *c = rep_CONTIN (obj);
1195
rep_MARKVAL (c->throw_value);
1196
rep_MARKVAL (c->special_bindings);
1197
1198
for (barrier = c->barriers;
1199
barrier != 0 && !SP_OLDER_P ((char *) barrier, c->stack_bottom);
1200
barrier = FIXUP(rep_barrier *, c, barrier)->next)
1201
{
1202
rep_barrier *ptr = FIXUP (rep_barrier *, c, barrier);
1203
rep_thread *t;
1204
for (t = ptr->head; t != 0; t = t->next)
1205
rep_MARKVAL (rep_VAL (t));
1206
for (t = ptr->susp_head; t != 0; t = t->next)
1207
rep_MARKVAL (rep_VAL (t));
1208
rep_MARKVAL (rep_VAL (ptr->active));
1209
}
1210
for (roots = c->gc_roots;
1211
roots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom);
1212
roots = FIXUP(rep_GC_root *, c, roots)->next)
1213
{
1214
repv *ptr = FIXUP(rep_GC_root *, c, roots)->ptr;
1215
rep_MARKVAL (*FIXUP(repv *, c, ptr));
1216
}
1217
for (nroots = c->gc_n_roots;
1218
nroots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom);
1219
nroots = FIXUP(rep_GC_n_roots *, c, nroots)->next)
1220
{
1221
repv *ptr = FIXUP(repv *, c, FIXUP(rep_GC_n_roots *, c, nroots)->first);
1222
int n = FIXUP(rep_GC_n_roots *, c, nroots)->count, i;
1223
for (i = 0; i < n; i++)
1224
rep_MARKVAL (ptr[i]);
1225
}
1226
for (calls = c->call_stack;
1227
calls != 0 && !SP_OLDER_P ((char *) calls, c->stack_bottom);
1228
calls = FIXUP(struct rep_Call *, c, calls)->next)
1229
{
1230
struct rep_Call *lc = FIXUP(struct rep_Call *, c, calls);
1231
rep_MARKVAL(lc->fun);
1232
rep_MARKVAL(lc->args);
1233
rep_MARKVAL(lc->current_form);
1234
rep_MARKVAL(lc->saved_env);
1235
rep_MARKVAL(lc->saved_structure);
1236
}
1237
for (matches = c->regexp_data;
1238
matches != 0 && !SP_OLDER_P ((char *) matches, c->stack_bottom);
1239
matches = FIXUP(struct rep_saved_regexp_data *, c, matches)->next)
1240
{
1241
struct rep_saved_regexp_data *sd
1242
= FIXUP(struct rep_saved_regexp_data *, c, matches);
1243
assert (sd->type == rep_reg_obj || sd->type == rep_reg_string);
1244
if(sd->type == rep_reg_obj)
1245
{
1246
int i;
1247
for(i = 0; i < rep_NSUBEXP; i++)
1248
{
1249
rep_MARKVAL(sd->matches.obj.startp[i]);
1250
rep_MARKVAL(sd->matches.obj.endp[i]);
1251
}
1252
}
1253
rep_MARKVAL(sd->data);
1254
}
1255
}
1256
1257
static void
1258
mark_all (void)
1259
{
1260
rep_barrier *ptr;
1261
for (ptr = barriers; ptr != 0; ptr = ptr->next)
1262
{
1263
rep_thread *t;
1264
for (t = ptr->head; t != 0; t = t->next)
1265
rep_MARKVAL (rep_VAL (t));
1266
for (t = ptr->susp_head; t != 0; t = t->next)
1267
rep_MARKVAL (rep_VAL (t));
1268
rep_MARKVAL (rep_VAL (ptr->active));
1269
}
1270
}
1271
1272
static void
1273
sweep_cont (void)
1274
{
1275
rep_continuation *c = continuations;
1276
continuations = 0;
1277
while (c)
1278
{
1279
rep_continuation *next = c->next;
1280
if (!rep_GC_CELL_MARKEDP (rep_VAL (c)))
1281
{
1282
rep_free (c->stack_copy);
1283
rep_FREE_CELL (c);
1284
}
1285
else
1286
{
1287
rep_GC_CLR_CELL (rep_VAL (c));
1288
c->next = continuations;
1289
continuations = c;
1290
}
1291
c = next;
1292
}
1293
}
1294
1295
static void
1296
print_cont (repv stream, repv obj)
1297
{
1298
rep_stream_puts (stream, "#<continuation>", -1, rep_FALSE);
1299
}
1300
1301
static int
1302
continuation_type (void)
1303
{
1304
static int type;
1305
1306
if (type == 0)
1307
{
1308
type = rep_register_new_type ("continuation",
1309
rep_ptr_cmp, print_cont, print_cont,
1310
sweep_cont, mark_cont, mark_all,
1311
0, 0, 0, 0, 0, 0);
1312
}
1313
1314
return type;
1315
}
1316
1317
static void
1318
mark_thread (repv obj)
1319
{
1320
rep_MARKVAL (rep_VAL (THREAD (obj)->cont));
1321
rep_MARKVAL (THREAD (obj)->env);
1322
rep_MARKVAL (THREAD (obj)->structure);
1323
rep_MARKVAL (THREAD (obj)->name);
1324
rep_MARKVAL (THREAD (obj)->exit_val);
1325
}
1326
1327
static void
1328
sweep_thread (void)
1329
{
1330
rep_thread *t = threads;
1331
threads = 0;
1332
while (t)
1333
{
1334
rep_thread *next = t->next_alloc;
1335
if (!rep_GC_CELL_MARKEDP (rep_VAL (t)))
1336
rep_FREE_CELL (t);
1337
else
1338
{
1339
rep_GC_CLR_CELL (rep_VAL (t));
1340
t->next_alloc = threads;
1341
threads = t;
1342
}
1343
t = next;
1344
}
1345
}
1346
1347
static void
1348
print_thread (repv stream, repv obj)
1349
{
1350
rep_stream_puts (stream, "#<thread", -1, rep_FALSE);
1351
if (rep_STRINGP (THREAD (obj)->name))
1352
{
1353
rep_stream_putc (stream, ' ');
1354
rep_stream_puts (stream, rep_STR (THREAD (obj)->name), -1, rep_FALSE);
1355
}
1356
rep_stream_putc (stream, '>');
1357
}
1358
1359
static int
1360
thread_type (void)
1361
{
1362
static int type;
1363
1364
if (type == 0)
1365
{
1366
type = rep_register_new_type ("thread", rep_ptr_cmp,
1367
print_thread, print_thread,
1368
sweep_thread, mark_thread,
1369
0, 0, 0, 0, 0, 0, 0);
1370
}
1371
1372
return type;
1373
}
1374
1375
#else /* WITH_CONTINUATIONS */
1376
1377
repv
1378
rep_call_with_barrier (repv (*callback)(repv), repv arg,
1379
rep_bool closed, void (*in)(void *),
1380
void (*out)(void *), void *data)
1381
{
1382
return callback (arg);
1383
}
1384
1385
DEFSTRING (ccc_missing, "call/cc was not included in this system");
1386
1387
static repv
1388
call_cc_missing (void)
1389
{
1390
return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&ccc_missing)));
1391
}
1392
1393
1394
DEFUN ("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1)
1395
{
1396
return call_cc_missing ();
1397
}
1398
1399
DEFUN("continuation-callable-p", Fcontinuation_callable_p,
1400
Scontinuation_callable_p, (repv cont), rep_Subr1)
1401
{
1402
return rep_signal_arg_error (cont, 1);
1403
}
1404
1405
u_long
1406
rep_max_sleep_for (void)
1407
{
1408
return UINT_MAX;
1409
}
1410
1411
#endif /* !WITH_CONTINUATIONS */
1412
1413
1414
/* misc lisp functions */
1415
1416
/* Bind one object, returning the handle to later unbind by. */
1417
static repv
1418
bind_object(repv obj)
1419
{
1420
rep_type *t = rep_get_data_type(rep_TYPE(obj));
1421
if (t->bind != 0)
1422
return t->bind(obj);
1423
else
1424
return Qnil;
1425
}
1426
1427
static void
1428
unbind_object (repv handle)
1429
{
1430
repv obj;
1431
rep_type *t;
1432
if (handle == Qnil)
1433
return;
1434
else if (rep_CONSP (handle))
1435
obj = rep_CAR (handle);
1436
else
1437
obj = handle;
1438
t = rep_get_data_type (rep_TYPE (obj));
1439
if (t->unbind != 0)
1440
t->unbind(handle);
1441
}
1442
1443
static void
1444
call_with_inwards (void *data_)
1445
{
1446
repv *data = data_;
1447
if (data[0] != rep_NULL)
1448
data[1] = bind_object (data[0]);
1449
else
1450
data[1] = rep_NULL;
1451
}
1452
1453
static void
1454
call_with_outwards (void *data_)
1455
{
1456
repv *data = data_;
1457
if (data[1] != rep_NULL)
1458
{
1459
unbind_object (data[1]);
1460
data[1] = rep_NULL;
1461
}
1462
}
1463
1464
DEFUN("call-with-object", Fcall_with_object,
1465
Scall_with_object, (repv arg, repv thunk), rep_Subr2) /*
1466
::doc:rep.lang.interpreter#call-with-object::
1467
call-with-object ARG THUNK
1468
1469
Call the zero-parameter function THUNK, with object ARG temporarily
1470
`bound' (a type-specific operation, usually to make ARG `active' in
1471
some way). When THUNK returns ARG is unbound. The value returned by
1472
THUNK is then returned.
1473
1474
If THUNK is ever left due to a continuation being invoked, ARG will be
1475
unbound. If THUNK is subsequently reentered, ARG will be rebound.
1476
::end:: */
1477
{
1478
repv data[2]; /* { ARG, HANDLE } */
1479
data[0] = arg;
1480
data[1] = bind_object(data[0]);
1481
if (data[1] != rep_NULL)
1482
{
1483
repv ret;
1484
rep_GC_n_roots gc_data;
1485
rep_PUSHGCN (gc_data, data, 2);
1486
ret = rep_call_with_barrier (rep_call_lisp0, thunk,
1487
rep_FALSE, call_with_inwards,
1488
call_with_outwards, data);
1489
unbind_object (data[1]);
1490
rep_POPGCN;
1491
return ret;
1492
}
1493
else
1494
return rep_NULL;
1495
}
1496
1497
DEFUN("call-with-dynamic-root", Fcall_with_dynamic_root,
1498
Scall_with_dynamic_root, (repv thunk), rep_Subr1) /*
1499
::doc:rep.lang.interpreter#call-with-dynamic-root::
1500
call-with-dynamic-root THUNK
1501
1502
Call the zero-parameter function THUNK, as the root of a new execution
1503
environment. This means that the continuation of THUNK will always be
1504
reached once, and once only. Any continuations above the new root may
1505
not be invoked from inside the root.
1506
::end:: */
1507
{
1508
return rep_call_with_barrier (rep_call_lisp0, thunk, rep_TRUE, 0, 0, 0);
1509
}
1510
1511
static void
1512
call_in (void *data_)
1513
{
1514
repv *data = data_;
1515
if (data[0] != Qnil)
1516
rep_call_lisp0 (data[0]);
1517
}
1518
1519
static void
1520
call_out (void *data_)
1521
{
1522
repv *data = data_;
1523
if (data[1] != Qnil)
1524
rep_call_lisp0 (data[1]);
1525
}
1526
1527
DEFUN("call-with-barrier", Fcall_with_barrier, Scall_with_barrier,
1528
(repv thunk, repv closed, repv in, repv out), rep_Subr4) /*
1529
::doc:rep.lang.interpreter#call-with-barrier::
1530
call-with-barrier THUNK CLOSED [IN-THUNK] [OUT-THUNK]
1531
1532
Call THUNK inside a new execution environment. If CLOSED is non-`nil'
1533
then the new environment will be exited exactly once (i.e.
1534
continuations may not pass through it).
1535
1536
Alternatively, if CLOSED is `nil' then the environment is said to be
1537
`open' and continuations may cause control to flow into and out of the
1538
new environment. As this happens one of IN-THUNK or OUT-THUNK will be
1539
called (if defined).
1540
1541
The value of this function is the value returned by THUNK.
1542
::end:: */
1543
{
1544
repv thunks[2], ret;
1545
rep_GC_n_roots gc_thunks;
1546
thunks[0] = in;
1547
thunks[1] = out;
1548
rep_PUSHGCN (gc_thunks, thunks, 2);
1549
ret = rep_call_with_barrier (rep_call_lisp0, thunk,
1550
closed == Qnil ? rep_FALSE : rep_TRUE,
1551
call_in, call_out, thunks);
1552
rep_POPGCN;
1553
return ret;
1554
}
1555
1556
DEFUN("make-thread", Fmake_thread, Smake_thread, (repv thunk, repv name), rep_Subr2) /*
1557
::doc:rep.threads#make-thread::
1558
make-thread THUNK [NAME]
1559
1560
Create and return an object representing a new thread of execution. The
1561
new thread will begin by calling THUNK, a function with zero
1562
parameters.
1563
::end:: */
1564
{
1565
#ifdef WITH_CONTINUATIONS
1566
return rep_VAL (make_thread (thunk, name, rep_FALSE));
1567
#else
1568
return call_cc_missing ();
1569
#endif
1570
}
1571
1572
DEFUN("make-suspended-thread", Fmake_suspended_thread, Smake_suspended_thread,
1573
(repv thunk, repv name), rep_Subr2) /*
1574
::doc:rep.threads#make-suspended-thread::
1575
make-suspended-thread THUNK [NAME]
1576
1577
Identical to `make-thread', except that the created thread will be
1578
immediately put in the suspended state.
1579
::end:: */
1580
{
1581
#ifdef WITH_CONTINUATIONS
1582
return rep_VAL (make_thread (thunk, name, rep_TRUE));
1583
#else
1584
return call_cc_missing ();
1585
#endif
1586
}
1587
1588
DEFUN("thread-yield", Fthread_yield, Sthread_yield, (void), rep_Subr0) /*
1589
::doc:rep.threads#thread-yield::
1590
thread-yield
1591
1592
Pass control away from the current thread if other threads are waiting
1593
to run.
1594
::end:: */
1595
{
1596
#ifdef WITH_CONTINUATIONS
1597
return thread_yield () ? Qt : Qnil;
1598
#else
1599
return Qnil;
1600
#endif
1601
}
1602
1603
DEFUN("thread-delete", Fthread_delete, Sthread_delete, (repv th), rep_Subr1) /*
1604
::doc:rep.threads#thread-delete::
1605
thread-delete [THREAD]
1606
1607
Mark THREAD (or the current thread), as being deleted. It will not be
1608
switched to in the future. If the current thread is deleted, control
1609
will be passed to the next runnable thread. Deleting the last runnable
1610
thread results forces the containing dynamic root to be closed.
1611
::end:: */
1612
{
1613
#ifdef WITH_CONTINUATIONS
1614
if (th == Qnil)
1615
th = Fcurrent_thread (Qnil);
1616
rep_DECLARE1 (th, THREADP);
1617
thread_delete (THREAD (th));
1618
return Qnil;
1619
#else
1620
return rep_signal_arg_error (th, 1);
1621
#endif
1622
}
1623
1624
DEFUN("thread-suspend", Fthread_suspend,
1625
Sthread_suspend, (repv th, repv msecs), rep_Subr2) /*
1626
::doc:rep.threads#thread-suspend::
1627
thread-suspend [THREAD] [MSECS]
1628
1629
Mark THREAD (or the current thread) as being suspended. It will not be
1630
selected until it has this status removed. Suspending the current
1631
thread will pass control to the next runnable thread. If there are no
1632
runnable threads, then sleep until the next thread becomes runnable.
1633
1634
Returns true if the timeout was reached.
1635
::end:: */
1636
{
1637
#ifdef WITH_CONTINUATIONS
1638
long timeout;
1639
repv no_timeout;
1640
if (th == Qnil)
1641
th = Fcurrent_thread (Qnil);
1642
rep_DECLARE1 (th, THREADP);
1643
rep_DECLARE2_OPT (msecs, rep_NUMERICP);
1644
timeout = (msecs == Qnil) ? 1 : rep_get_long_int (msecs);
1645
thread_suspend (THREAD (th), timeout, 0, 0);
1646
no_timeout = THREAD (th)->exit_val;
1647
THREAD (th)->exit_val = rep_NULL;
1648
return no_timeout == Qnil ? Qt : Qnil;
1649
#else
1650
return rep_signal_arg_error (th, 1);
1651
#endif
1652
}
1653
1654
#ifdef WITH_CONTINUATIONS
1655
static rep_bool
1656
thread_join_poller (rep_thread *t, void *arg)
1657
{
1658
rep_thread *th = arg;
1659
return (th->car & TF_EXITED) ? rep_TRUE : rep_FALSE;
1660
}
1661
#endif
1662
1663
DEFUN("thread-join", Fthread_join,
1664
Sthread_join, (repv th, repv msecs, repv def), rep_Subr3) /*
1665
::doc:rep.threads#thread-join::
1666
thread-join THREAD [MSECS] [DEFAULT-VALUE]
1667
1668
Suspend the current thread until THREAD has exited, or MSECS
1669
milliseconds have passed. If THREAD exits normally, return the value of
1670
the last form it evaluated, else return DEFAULT-VALUE.
1671
1672
It is an error to call thread-join on a THREAD that is not a member of
1673
current dynamic root.
1674
::end:: */
1675
{
1676
#ifdef WITH_CONTINUATIONS
1677
repv self = Fcurrent_thread (Qnil);
1678
rep_DECLARE (1, th, XTHREADP (th) && th != self
1679
&& THREAD (th)->cont->root == root_barrier);
1680
if (THREADP (self))
1681
{
1682
rep_GC_root gc_th;
1683
rep_PUSHGC (gc_th, th);
1684
rep_DECLARE2_OPT (msecs, rep_NUMERICP);
1685
thread_suspend (THREAD (self),
1686
rep_get_long_int (msecs),
1687
thread_join_poller, THREAD (th));
1688
THREAD (self)->exit_val = rep_NULL;
1689
rep_POPGC;
1690
if ((THREAD (th)->car & TF_EXITED) && THREAD (th)->exit_val)
1691
return THREAD (th)->exit_val;
1692
}
1693
return def;
1694
#else
1695
return rep_signal_arg_error (th, 1);
1696
#endif
1697
}
1698
1699
DEFUN("thread-wake", Fthread_wake, Sthread_wake, (repv th), rep_Subr1) /*
1700
::doc:rep.threads#thread-wake::
1701
thread-wake [THREAD]
1702
1703
If THREAD (or the current thread) is currently suspended, mark it as
1704
being runnable once more.
1705
::end:: */
1706
{
1707
#ifdef WITH_CONTINUATIONS
1708
if (th == Qnil)
1709
th = Fcurrent_thread (Qnil);
1710
rep_DECLARE1 (th, THREADP);
1711
THREAD (th)->exit_val = Qt; /* signals timeout not reached */
1712
thread_wake (THREAD (th));
1713
return Qnil;
1714
#else
1715
return rep_signal_arg_error (th, 1);
1716
#endif
1717
}
1718
1719
DEFUN("threadp", Fthreadp, Sthreadp, (repv arg), rep_Subr1) /*
1720
::doc:rep.threads#threadp::
1721
threadp ARG
1722
1723
Return `t' if ARG is a thread object.
1724
::end:: */
1725
{
1726
#ifdef WITH_CONTINUATIONS
1727
return XTHREADP (arg) ? Qt : Qnil;
1728
#else
1729
return Qnil;
1730
#endif
1731
}
1732
1733
DEFUN("thread-suspended-p", Fthread_suspended_p,
1734
Sthread_suspended_p, (repv th), rep_Subr1) /*
1735
::doc:rep.threads#thread-suspended-p::
1736
thread-suspended-p THREAD
1737
1738
Return `t' if THREAD is currently suspended from running.
1739
::end:: */
1740
{
1741
#ifdef WITH_CONTINUATIONS
1742
rep_DECLARE1 (th, THREADP);
1743
return (THREAD (th)->car & TF_SUSPENDED) ? Qt : Qnil;
1744
#else
1745
return rep_signal_arg_error (th, 1);
1746
#endif
1747
}
1748
1749
DEFUN("thread-exited-p", Fthread_exited_p,
1750
Sthread_exited_p, (repv th), rep_Subr1) /*
1751
::doc:rep.threads#thread-exited-p::
1752
thread-exited-p THREAD
1753
1754
Return `t' if THREAD has exited.
1755
::end:: */
1756
{
1757
#ifdef WITH_CONTINUATIONS
1758
rep_DECLARE1 (th, XTHREADP);
1759
return (THREAD (th)->car & TF_EXITED) ? Qt : Qnil;
1760
#else
1761
return rep_signal_arg_error (th, 1);
1762
#endif
1763
}
1764
1765
DEFUN("current-thread", Fcurrent_thread,
1766
Scurrent_thread, (repv depth), rep_Subr1) /*
1767
::doc:rep.threads#current-thread::
1768
current-thread [DEPTH]
1769
1770
Return the currently executing thread.
1771
::end:: */
1772
{
1773
#ifdef WITH_CONTINUATIONS
1774
rep_barrier *root;
1775
1776
rep_DECLARE1_OPT (depth, rep_INTP);
1777
if (depth == Qnil)
1778
depth = rep_MAKE_INT (0);
1779
1780
if (depth == rep_MAKE_INT (0))
1781
ensure_default_thread ();
1782
1783
root = get_dynamic_root (rep_INT (depth));
1784
if (root == 0)
1785
return Qnil;
1786
else
1787
return (root->active) ? rep_VAL (root->active) : Qnil;
1788
#else
1789
return Qnil;
1790
#endif
1791
}
1792
1793
DEFUN("all-threads", Fall_threads, Sall_threads, (repv depth), rep_Subr1) /*
1794
::doc:rep.threads#all-threads::
1795
all-threads [DEPTH]
1796
1797
Return a list of all threads.
1798
::end:: */
1799
{
1800
#ifdef WITH_CONTINUATIONS
1801
rep_barrier *root;
1802
1803
rep_DECLARE1_OPT (depth, rep_INTP);
1804
if (depth == Qnil)
1805
depth = rep_MAKE_INT (0);
1806
1807
if (depth == rep_MAKE_INT (0))
1808
ensure_default_thread ();
1809
1810
root = get_dynamic_root (rep_INT (depth));
1811
if (root == 0)
1812
return Qnil;
1813
else
1814
{
1815
repv out = Qnil;
1816
rep_thread *ptr;
1817
for (ptr = root->susp_tail; ptr != 0; ptr = ptr->pred)
1818
out = Fcons (rep_VAL (ptr), out);
1819
for (ptr = root->tail; ptr != 0; ptr = ptr->pred)
1820
out = Fcons (rep_VAL (ptr), out);
1821
return out;
1822
}
1823
#else
1824
return Qnil;
1825
#endif
1826
}
1827
1828
DEFUN("thread-forbid", Fthread_forbid, Sthread_forbid, (void), rep_Subr0) /*
1829
::doc:rep.threads#thread-forbid::
1830
thread-forbid
1831
1832
Increment the thread preemption lock. When greather than zero all
1833
preemption of threads is disabled. Returns `t' if preemption is blocked
1834
as this function returns.
1835
::end:: */
1836
{
1837
rep_FORBID;
1838
return rep_PREEMPTABLE_P ? Qnil : Qt;
1839
}
1840
1841
DEFUN("thread-permit", Fthread_permit, Sthread_permit, (void), rep_Subr0) /*
1842
::doc:rep.threads#thread-permit::
1843
thread-permit
1844
1845
Decrement the thread preemption lock. When greather than zero all
1846
preemption of threads is disabled. Returns `t' if preemption is blocked
1847
as this function returns.
1848
::end:: */
1849
{
1850
rep_PERMIT;
1851
return rep_PREEMPTABLE_P ? Qnil : Qt;
1852
}
1853
1854
DEFUN("thread-name", Fthread_name, Sthread_name, (repv th), rep_Subr1) /*
1855
::doc:rep.threads#thread-name:
1856
thread-name THREAD
1857
1858
Return the name of the thread THREAD.
1859
::end:: */
1860
{
1861
#ifdef WITH_CONTINUATIONS
1862
rep_DECLARE1 (th, XTHREADP);
1863
return THREAD (th)->name;
1864
#else
1865
return rep_signal_arg_error (th, 1);
1866
#endif
1867
}
1868
1869
1870
/* dl hooks */
1871
1872
void
1873
rep_continuations_init (void)
1874
{
1875
repv tem = rep_push_structure ("rep.lang.interpreter");
1876
1877
#ifdef WITH_CONTINUATIONS
1878
exit_barrier_cell = Fcons (Qnil, Qnil);
1879
rep_mark_static (&exit_barrier_cell);
1880
rep_INTERN(continuation);
1881
rep_ADD_INTERNAL_SUBR(Sprimitive_invoke_continuation);
1882
#endif
1883
1884
rep_ADD_SUBR(Scall_cc);
1885
rep_ADD_SUBR(Scontinuation_callable_p);
1886
rep_ADD_SUBR(Scall_with_object);
1887
rep_ADD_SUBR(Scall_with_dynamic_root);
1888
rep_ADD_SUBR(Scall_with_barrier);
1889
rep_pop_structure (tem);
1890
1891
tem = rep_push_structure ("rep.threads");
1892
rep_ADD_SUBR(Smake_thread);
1893
rep_ADD_SUBR(Smake_suspended_thread);
1894
rep_ADD_SUBR(Sthread_yield);
1895
rep_ADD_SUBR(Sthread_delete);
1896
rep_ADD_SUBR(Sthread_suspend);
1897
rep_ADD_SUBR(Sthread_join);
1898
rep_ADD_SUBR(Sthread_wake);
1899
rep_ADD_SUBR(Sthreadp);
1900
rep_ADD_SUBR(Sthread_suspended_p);
1901
rep_ADD_SUBR(Sthread_exited_p);
1902
rep_ADD_SUBR(Scurrent_thread);
1903
rep_ADD_SUBR(Sall_threads);
1904
rep_ADD_SUBR(Sthread_forbid);
1905
rep_ADD_SUBR(Sthread_permit);
1906
rep_ADD_SUBR(Sthread_name);
1907
rep_pop_structure (tem);
1908
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1