1 /*
2 * lazy.c - lazy evaluation constructs
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/priv/atomicP.h"
37
38 /*==================================================================
39 * Promise
40 */
41
42 /* NB: We adopted the semantics described in srfi-45.
43 * http://srfi.schemers.org/srfi-45/srfi-45.html
44 *
45 * The 'forced' flag indicates one of two state of a promise.
46 *
47 * forced == TRUE: the promise is in 'eager' state. code has a value.
48 * forced == FALSE: the promise is in 'lazy' state. code has a thunk.
49 *
50 * [syntax] lazy expr : Promise a -> Promise a
51 * Creates a lazy promise, delaying evaluation of expr.
52 * [procedure] eager expr : a -> Promise a
53 * Creates a eager promise, encapsulating the result of evaluation of expr.
54 * [syntax] delay expr : a -> Promise a
55 * (lazy (eager expr))
56 * [procedure] force expr : Promise a -> a
57 *
58 * One might want to create a subtype of promise; for example, srfi-40
59 * requires the stream type to be distinct from other types, although
60 * it is essentially a promise with a specific usage pattern. To realize
61 * that portably, one need effectively reimplement force/delay mechanism
62 * (since 'eager' operation is required to return Stream instread of Promise),
63 * which is kind of shame.
64 *
65 * Gauche experimentally tries to address this problem by allowing the
66 * program to add a specific KIND object to a promise instance.
67 *
68 * Thread safety: It is safe that more than one thread force a promise
69 * simultaneously. Only one thread does calculation.
70 */
71
72 /*
73 * The body of promise
74 */
75 typedef struct ScmPromiseContentRec {
76 int forced; /* TRUE if code has a thunk */
77 ScmObj code; /* thunk or value */
78 ScmInternalMutex mutex;
79 ScmVM *owner; /* who is working on this? */
80 int count; /* count for recursive lock */
81 } ScmPromiseContent;
82
83 /*
84 * class stuff
85 */
86
promise_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)87 static void promise_print(ScmObj obj, ScmPort *port,
88 ScmWriteContext *ctx SCM_UNUSED)
89 {
90 ScmPromise *p = (ScmPromise*)obj;
91 const char *forced = p->content->forced? " (forced)" : "";
92 if (SCM_FALSEP(p->kind)) {
93 Scm_Printf(port, "#<promise %p%s>", p, forced);
94 } else {
95 Scm_Printf(port, "#<promise(%S) %p%s>", p->kind, p, forced);
96 }
97 }
98
99 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_PromiseClass, promise_print);
100
101 /*
102 * promise object
103 */
104
Scm_MakePromise(int forced,ScmObj code)105 ScmObj Scm_MakePromise(int forced, ScmObj code)
106 {
107 ScmPromise *p = SCM_NEW(ScmPromise);
108 ScmPromiseContent *c = SCM_NEW(ScmPromiseContent);
109 SCM_SET_CLASS(p, SCM_CLASS_PROMISE);
110 SCM_INTERNAL_MUTEX_INIT(c->mutex);
111 c->owner = NULL;
112 c->count = 0;
113 c->forced = forced;
114 c->code = code;
115 p->content = c;
116 p->kind = SCM_FALSE;
117 return SCM_OBJ(p);
118 }
119
120 /*
121 * force
122 */
123
release_promise(ScmObj * args SCM_UNUSED,int nargs SCM_UNUSED,void * data)124 static ScmObj release_promise(ScmObj *args SCM_UNUSED,
125 int nargs SCM_UNUSED,
126 void *data)
127 {
128 ScmPromise *p = SCM_PROMISE(data);
129 p->content->owner = NULL;
130 SCM_INTERNAL_MUTEX_UNLOCK(p->content->mutex);
131 return SCM_UNDEFINED;
132 }
133
install_release_thunk(ScmVM * vm,ScmObj promise)134 static void install_release_thunk(ScmVM *vm, ScmObj promise)
135 {
136 /* TODO: the before thunk must be something that
137 prevents restarting the execution process. */
138 vm->handlers = Scm_Acons(Scm_NullProc(),
139 Scm_MakeSubr(release_promise,
140 (void*)promise, 0, 0,
141 SCM_MAKE_STR("promise_release")),
142 vm->handlers);
143 }
144
force_cc(ScmObj result,void ** data)145 static ScmObj force_cc(ScmObj result, void **data)
146 {
147 ScmPromise *p = (ScmPromise*)data[0];
148 ScmObj handlers = (ScmObj)data[1];
149
150 /* Check if the original promise is forced by evaluating
151 the delayed expr to detect recursive force situation */
152 if (!p->content->forced) {
153 if (SCM_PROMISEP(result)) {
154 /* Deal with a recursive promise introduced by lazy operation.
155 See srfi-45 for the details. */
156 p->content->forced = SCM_PROMISE(result)->content->forced;
157 p->content->code = SCM_PROMISE(result)->content->code;
158 SCM_PROMISE(result)->content = p->content;
159 } else {
160 /* This isn't supposed to happen if 'lazy' is used properly
161 on the promise-yielding procedure, but we can't prevent
162 one from writing (lazy 3). So play safe. */
163 p->content->forced = TRUE;
164 p->content->code = result;
165 }
166 }
167 if (--p->content->count == 0) {
168 p->content->owner = NULL;
169 SCM_INTERNAL_MUTEX_UNLOCK(p->content->mutex);
170 }
171 Scm_VM()->handlers = handlers;
172 SCM_RETURN(Scm_VMForce(SCM_OBJ(p)));
173 }
174
Scm_VMForce(ScmObj obj)175 ScmObj Scm_VMForce(ScmObj obj)
176 {
177 if (!SCM_PROMISEP(obj)) {
178 SCM_RETURN(obj);
179 } else {
180 ScmPromiseContent *c = SCM_PROMISE(obj)->content;
181
182 if (c->forced) SCM_RETURN(c->code);
183 else {
184 ScmVM *vm = Scm_VM();
185 void *data[2];
186 data[0] = obj;
187 data[1] = vm->handlers;
188
189 if (c->owner == vm) {
190 /* we already have the lock and evaluating this promise. */
191 c->count++;
192 Scm_VMPushCC(force_cc, data, 2);
193 SCM_RETURN(Scm_VMApply0(c->code));
194 } else {
195 /* TODO: check if the executing thread terminates
196 prematurely */
197 SCM_INTERNAL_MUTEX_LOCK(c->mutex);
198 if (c->forced) {
199 SCM_INTERNAL_MUTEX_UNLOCK(c->mutex);
200 SCM_RETURN(c->code);
201 }
202 SCM_ASSERT(c->owner == NULL);
203 c->owner = vm;
204 install_release_thunk(vm, obj);
205 c->count++;
206 /* mutex is unlocked by force_cc. */
207 Scm_VMPushCC(force_cc, data, 2);
208 SCM_RETURN(Scm_VMApply0(c->code));
209 }
210 }
211 }
212 }
213
Scm_Force(ScmObj obj)214 ScmObj Scm_Force(ScmObj obj)
215 {
216 if (!SCM_PROMISEP(obj)) {
217 SCM_RETURN(obj);
218 } else {
219 ScmPromiseContent *c = SCM_PROMISE(obj)->content;
220 if (c->forced) SCM_RETURN(c->code);
221
222 static ScmObj force = SCM_UNDEFINED;
223 SCM_BIND_PROC(force, "force", Scm_SchemeModule());
224 return Scm_ApplyRec1(force, obj);
225 }
226 }
227
228 /*=================================================================
229 * Lazy pairs
230 *
231 * Lazy pair is a lazy structure that can turn into a normal pair.
232 * If you check whether the object is pair or not by SCM_PAIRP,
233 * it is 'forced' to become a pair. The forcing is
234 * identity-preserving; that is, once a lazy pair is forced, the pointer
235 * now becomes a pair. It is a critical attribute to make the
236 * forcing implicit---we can't do it for general values.
237 * Since the forcing is implicit, majority of the code won't see
238 * ScmLazyPair.
239 *
240 * The identity-preserving property requires us to generate
241 * one item ahead from the generator, for we can't replace lazypair
242 * to (), which is an immediate value.
243 */
244
245 /*
246
247 (0) Initial state
248
249 +---------------+
250 | LazyPair tag |
251 +---------------+
252 | ScmObj item |
253 +---------------+
254 | ScmObj | ----> generator
255 +---------------+
256 | (AO_t)0 |
257 +---------------+
258
259
260 (1) The first one (owner) grabs the packet, then evaluates the generator.
261 The grabbing is done by CAS to make it atomic.
262
263 +---------------+
264 | LazyPair tag |
265 +---------------+
266 | ScmObj item |
267 +---------------+
268 | ScmObj | ----> generator
269 +---------------+
270 | (AO_t)owner |
271 +---------------+
272
273
274 (2) If generator yields a non-EOF value, owner first creates a
275 new LazyPair...
276
277 +---------------+
278 | LazyPair tag |
279 +---------------+
280 | ScmObj item |
281 +---------------+
282 | ScmObj | ------------------------+-> generator
283 +---------------+ |
284 | (AO_t)owner | |
285 +---------------+ |
286 |
287 +---------------+ |
288 | LazyPair tag | |
289 +---------------+ |
290 | ScmObj newitem| |
291 +---------------+ |
292 | ScmObj | -/
293 +---------------+
294 | (AO_t)0 |
295 +---------------+
296
297 (3) then it replaces the cdr pointer with the new LazyPair, and clear
298 the third slot.
299
300 +---------------+
301 | LazyPair tag |
302 +---------------+
303 | ScmObj | -\
304 +---------------+ |
305 | NIL | |
306 +---------------+ |
307 | (AO_t)owner | |
308 +---------------+ |
309 |
310 | +---------------+
311 \-> | LazyPair tag |
312 +---------------+
313 | ScmObj newitem|
314 +---------------+
315 | ScmObj | ---> generator
316 +---------------+
317 | (AO_t)0 |
318 +---------------+
319
320
321 (4) and replaces the car pointer with the lookahead value, which makes
322 the original object an (extended) pair,
323
324 +---------------+
325 | ScmObj item |
326 +---------------+
327 | ScmObj | -\
328 +---------------+ |
329 | NIL | |
330 +---------------+ |
331 | (AO_t)owner | |
332 +---------------+ |
333 |
334 | +---------------+
335 \-> | LazyPair tag |
336 +---------------+
337 | ScmObj newitem|
338 +---------------+
339 | ScmObj | ---> generator
340 +---------------+
341 | (AO_t)0 |
342 +---------------+
343
344 (5) finally set the fourth slot with 1, just not to grab the pointer
345 to the owner thread so that the owner thread won't be retained
346 unnecessarily.
347
348 +---------------+
349 | ScmObj item |
350 +---------------+
351 | ScmObj | -\
352 +---------------+ |
353 | NIL | |
354 +---------------+ |
355 | (AO_t)1 | |
356 +---------------+ |
357 |
358 | +---------------+
359 \-> | LazyPair tag |
360 +---------------+
361 | ScmObj newitem|
362 +---------------+
363 | ScmObj | ---> generator
364 +---------------+
365 | (AO_t)0 |
366 +---------------+
367
368
369 (2') If generator yields EOF, we don't create a new lazy pair.
370 We first replace the second and third slot by NIL,
371
372 +---------------+
373 | LazyPair tag |
374 +---------------+
375 | NIL |
376 +---------------+
377 | NIL |
378 +---------------+
379 | (AO_t)owner |
380 +---------------+
381
382 (3') then replace the car part by the cached value, which turns
383 the object to an (extended) pair,
384
385 +---------------+
386 | ScmObj item |
387 +---------------+
388 | NIL |
389 +---------------+
390 | NIL |
391 +---------------+
392 | (AO_t)owner |
393 +---------------+
394
395
396 (4') then clear the fourth slot to be GC-friendly.
397
398 +---------------+
399 | ScmObj item |
400 +---------------+
401 | NIL |
402 +---------------+
403 | NIL |
404 +---------------+
405 | (AO_t)1 |
406 +---------------+
407
408
409 Each step of the state transitions (0)->(1)->(2)->(3)->(4)->(5) and
410 (0)->(1)->(2')->(3')->(4') are atomic, so the observer see either
411 one of those states.
412 */
413
414 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_LazyPairClass, NULL);
415
416 /* The order is important - must correspond to ScmExtendedPair. */
417 struct ScmLazyPairRec {
418 SCM_HEADER;
419 ScmObj item;
420 ScmObj generator;
421 ScmAtomicVar owner;
422 };
423
Scm_MakeLazyPair(ScmObj item,ScmObj generator)424 ScmObj Scm_MakeLazyPair(ScmObj item, ScmObj generator)
425 {
426 ScmLazyPair *z = SCM_NEW(ScmLazyPair);
427 z->owner = (ScmAtomicWord)0;
428 SCM_SET_CLASS(z, SCM_CLASS_LAZY_PAIR);
429 z->generator = generator;
430 z->item = item;
431 return SCM_OBJ(z);
432 }
433
434 /* Force a lazy pair.
435 NB: When an error occurs during forcing, we release the lock of the
436 pair, so that the pair can be forced again. However, the generator
437 has already caused some side-effect before the error, so the next
438 forcing may not yield a correct next value. Another plausible option
439 is to mark the pair 'unforcible' permanently, by lp->owner == (AO_t)2,
440 and let subsequent attempt of forcing the pair fail.
441 */
Scm_ForceLazyPair(volatile ScmLazyPair * lp)442 ScmObj Scm_ForceLazyPair(volatile ScmLazyPair *lp)
443 {
444 static const ScmTimeSpec req = {0, 1000000};
445 ScmTimeSpec rem;
446 ScmVM *vm = Scm_VM();
447 ScmAtomicWord zero = 0; /* Need to use C11 intrinsic */
448
449 do {
450 if (AO_compare_and_swap_full(&lp->owner, zero, SCM_WORD(vm))) {
451 /* Here we own the lazy pair. */
452 ScmObj item = lp->item;
453 /* Calling generator might change VM state, so we protect
454 incomplete stack frame if there's any. */
455 int extra_frame_pushed = Scm__VMProtectStack(vm);
456 SCM_UNWIND_PROTECT {
457 ScmObj val = Scm_ApplyRec0(lp->generator);
458 ScmObj newgen = (vm->numVals == 1)? lp->generator : vm->vals[0];
459 vm->numVals = 1; /* make sure the extra val won't leak out */
460
461 if (SCM_EOFP(val)) {
462 lp->item = SCM_NIL;
463 lp->generator = SCM_NIL;
464 } else {
465 ScmObj newlp = Scm_MakeLazyPair(val, newgen);
466 lp->item = newlp;
467 lp->generator = SCM_NIL;
468 }
469 AO_nop_full();
470 SCM_SET_CAR_UNCHECKED(lp, item);
471 /* We don't need barrier here. */
472 lp->owner = (ScmAtomicWord)1;
473 } SCM_WHEN_ERROR {
474 lp->owner = (ScmAtomicWord)0; /*NB: See above about error handling*/
475 SCM_NEXT_HANDLER;
476 } SCM_END_PROTECT;
477 if (extra_frame_pushed) {
478 Scm__VMUnprotectStack(vm);
479 }
480 return SCM_OBJ(lp); /* lp is now an (extended) pair */
481 }
482 /* Check if we're already working on forcing this pair. Unlike
483 force/delay, We don't allow recursive forcing of lazy pair.
484 Since generators are supposed to be called every time to yield
485 a new value, so it is ambiguous what value should be returned
486 if a generator calls itself recursively. */
487 if (SCM_WORD(lp->owner) == SCM_WORD(vm)) {
488 /* NB: lp->owner will be reset by the original caller of
489 the generator. */
490 Scm_Error("Attempt to recursively force a lazy pair.");
491 }
492 /* Somebody's already working on forcing. Let's wait for it
493 to finish, or to abort. */
494 while (SCM_HTAG(lp) == 7 && lp->owner != 0) {
495 Scm_NanoSleep(&req, &rem);
496 }
497 } while (lp->owner == 0); /* we retry if the previous owner abandoned. */
498 return SCM_OBJ(lp);
499 }
500
501 /* Extract item and generator from lazy pair OBJ, without forcing it.
502 If OBJ is a lazy pair, item and generator is filled and TRUE is returned.
503 If OBJ is an ordinary pair (including the case that it was a lazy pair
504 but forced during execution of Scm_DecomposeLazyPair), returns its CAR
505 and a generator that returns its CDR.
506 Otherwise, returns FALSE. */
dummy_gen(ScmObj * args SCM_UNUSED,int nargs SCM_UNUSED,void * data)507 static ScmObj dummy_gen(ScmObj *args SCM_UNUSED,
508 int nargs SCM_UNUSED,
509 void *data)
510 {
511 ScmObj item;
512 ScmObj generator;
513 if (Scm_DecomposeLazyPair(SCM_OBJ(data), &item, &generator)) {
514 return Scm_Values2(item, generator);
515 } else {
516 return Scm_Values2(SCM_EOF, SCM_FALSE);
517 }
518 }
519
Scm_DecomposeLazyPair(ScmObj obj,ScmObj * item,ScmObj * generator)520 int Scm_DecomposeLazyPair(ScmObj obj, ScmObj *item, ScmObj *generator)
521 {
522 if (SCM_LAZY_PAIR_P(obj)) {
523 volatile ScmLazyPair *lp = SCM_LAZY_PAIR(obj);
524 static const ScmTimeSpec req = {0, 1000000};
525 ScmTimeSpec rem;
526 ScmVM *vm = Scm_VM();
527 ScmAtomicWord zero = 0; /* Need to use C11 intrinsic */
528
529 for (;;) {
530 if (AO_compare_and_swap_full(&lp->owner, zero, SCM_WORD(vm))) {
531 *item = lp->item;
532 *generator = lp->generator;
533 AO_nop_full();
534 lp->owner = 0;
535 return TRUE;
536 }
537 if (lp->owner == (ScmAtomicWord)1) {
538 /* Somebody else has forced OBJ. In the typical cases
539 where we call this function for co-recursive lazy
540 algorithms, this situation rarely happens. We fallthrough
541 to the SCM_PAIRP check below to return appropriate
542 values. */
543 SCM_ASSERT(SCM_HTAG(lp) != 7);
544 break;
545 }
546 Scm_NanoSleep(&req, &rem);
547 }
548 /*FALLTHROUGH*/
549 }
550 if (SCM_PAIRP(obj)) {
551 ScmObj next;
552 *item = SCM_CAR(obj);
553 next = SCM_NULLP(SCM_CDR(obj)) ? SCM_EOF : SCM_CDR(obj);
554 *generator = Scm_MakeSubr(dummy_gen, (void*)next, 0, 0, SCM_FALSE);
555 return TRUE;
556 } else {
557 return FALSE;
558 }
559 }
560
Scm_PairP(ScmObj x)561 int Scm_PairP(ScmObj x)
562 {
563 if (SCM_LAZY_PAIR_P(x)) {
564 Scm_ForceLazyPair(SCM_LAZY_PAIR(x));
565 return TRUE;
566 } else {
567 return FALSE;
568 }
569 }
570
571