/* Force a lazy pair.
NB: When an error occurs during forcing, we release the lock of the
pair, so that the pair can be forced again. However, the generator
has already caused some side-effect before the error, so the next
forcing may not yield a correct next value. Another plausible option
is to mark the pair 'unforcible' permanently, by lp->owner == (AO_t)2,
and let subsequent attempt of forcing the pair fail.
*/
ScmObj Scm_ForceLazyPair(volatile ScmLazyPair *lp)
{
static const struct timespec req = {0, 1000000};
struct timespec rem;
ScmVM *vm = Scm_VM();
do {
if (AO_compare_and_swap_full(&lp->owner, 0, SCM_WORD(vm))) {
/* Here we own the lazy pair. */
ScmObj item = lp->item;
/* Calling generator might change VM state, so we protect
incomplete stack frame if there's any. */
int extra_frame_pushed = Scm__VMProtectStack(vm);
SCM_UNWIND_PROTECT {
ScmObj val = Scm_ApplyRec0(lp->generator);
ScmObj newgen = (vm->numVals == 1)? lp->generator : vm->vals[0];
vm->numVals = 1; /* make sure the extra val won't leak out */
if (SCM_EOFP(val)) {
lp->item = SCM_NIL;
lp->generator = SCM_NIL;
} else {
ScmObj newlp = Scm_MakeLazyPair(val, newgen);
lp->item = newlp;
lp->generator = SCM_NIL;
}
AO_nop_full();
SCM_SET_CAR(lp, item);
/* We don't need barrier here. */
lp->owner = (AO_t)1;
} SCM_WHEN_ERROR {
lp->owner = (AO_t)0; /*NB: See above about error handling*/
SCM_NEXT_HANDLER;
} SCM_END_PROTECT;
if (extra_frame_pushed) {
Scm__VMUnprotectStack(vm);
}
return SCM_OBJ(lp); /* lp is now an (extended) pair */
}
/* Check if we're already working on forcing this pair. Unlike
force/delay, We don't allow recursive forcing of lazy pair.
Since generators are supposed to be called every time to yield
a new value, so it is ambiguous what value should be returned
if a generator calls itself recursively. */
if (lp->owner == SCM_WORD(vm)) {
/* NB: lp->owner will be reset by the original caller of
the generator. */
Scm_Error("Attempt to recursively force a lazy pair.");
}
/* Somebody's already working on forcing. Let's wait for it
to finish, or to abort. */
while (SCM_HTAG(lp) == 7 && lp->owner != 0) {
nanosleep(&req, &rem);
}
} while (lp->owner == 0); /* we retry if the previous owner abandoned. */
/*------------------------------------------------------------
* Bport fill
*/
static int bport_fill(ScmPort *p, int cnt)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->fill_proc)) {
return 0; /* indicates EOF */
}
ScmObj vec = Scm_MakeU8VectorFromArrayShared(
cnt, (unsigned char*)p->src.buf.buffer);
ScmObj r = Scm_ApplyRec(data->fill_proc, SCM_LIST1(vec));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
/*------------------------------------------------------------
* Bport flush
*/
static int bport_flush(ScmPort *p, int cnt, int forcep)
{
bport *data = (bport*)p->src.buf.data;
ScmObj vec, r;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->flush_proc)) {
return cnt; /* blackhole */
}
vec = Scm_MakeU8VectorFromArrayShared(cnt,
(unsigned char*)p->src.buf.buffer);
r = Scm_ApplyRec(data->flush_proc, SCM_LIST2(vec, SCM_MAKE_BOOL(forcep)));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
