From: Vincent Pit Date: Sun, 9 Sep 2012 22:06:07 +0000 (+0200) Subject: Implement yield() X-Git-Tag: v0.20~9 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=1cac52223ba0983d5d4007ab608fe4ea645eb037 Implement yield() --- diff --git a/MANIFEST b/MANIFEST index 6329c8a..cb425fd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -38,6 +38,10 @@ t/50-unwind-target.t t/51-unwind-multi.t t/52-unwind-context.t t/54-unwind-threads.t +t/55-yield-target.t +t/57-yield-context.t +t/58-yield-misc.t +t/59-yield-threads.t t/60-uplevel-target.t t/61-uplevel-args.t t/62-uplevel-return.t @@ -53,6 +57,7 @@ t/75-uid-uplevel.t t/79-uid-threads.t t/81-stress-level.t t/84-stress-unwind.t +t/85-stress-yield.t t/86-stress-uplevel.t t/87-stress-uid.t t/91-pod.t diff --git a/Upper.xs b/Upper.xs index 7ccd9dc..b1d9a08 100644 --- a/Upper.xs +++ b/Upper.xs @@ -337,6 +337,16 @@ typedef struct { OP proxy_op; } su_unwind_storage; +/* --- yield() global storage ---------------------------------------------- */ + +typedef struct { + I32 cxix; + I32 items; + SV **savesp; + UNOP leave_op; + OP proxy_op; +} su_yield_storage; + /* --- uplevel() data tokens and global storage ---------------------------- */ #define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0) @@ -434,6 +444,7 @@ typedef struct { typedef struct { char *stack_placeholder; su_unwind_storage unwind_storage; + su_yield_storage yield_storage; su_uplevel_storage uplevel_storage; su_uid_storage uid_storage; } my_cxt_t; @@ -906,12 +917,10 @@ done: /* --- Pop a context back -------------------------------------------------- */ -#if SU_DEBUG -# ifdef DEBUGGING -# define SU_CXNAME(C) PL_block_type[CxTYPE(C)] -# else -# define SU_CXNAME(C) "XXX" -# endif +#if SU_DEBUG && defined(DEBUGGING) +# define SU_CXNAME(C) PL_block_type[CxTYPE(C)] +#else +# define SU_CXNAME(C) "XXX" #endif STATIC void su_pop(pTHX_ void *ud) { @@ -1100,6 +1109,186 @@ STATIC void su_unwind(pTHX_ void *ud_) { PL_op = &(MY_CXT.unwind_storage.proxy_op); } +/* --- Yield --------------------------------------------------------------- */ + +#if SU_HAS_PERL(5, 10, 0) +# define SU_RETOP_SUB(C) ((C)->blk_sub.retop) +# define SU_RETOP_EVAL(C) ((C)->blk_eval.retop) +# define SU_RETOP_LOOP(C) ((C)->blk_loop.my_op->op_lastop->op_next) +# define SU_RETOP_GIVEN(C) ((C)->blk_givwhen.leave_op->op_next) +#else +# define SU_RETOP_SUB(C) ((C)->blk_oldretsp > 0 ? PL_retstack[(C)->blk_oldretsp - 1] : NULL) +# define SU_RETOP_EVAL(C) SU_RETOP_SUB(C) +# define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next) +#endif + +STATIC void su_yield(pTHX_ void *ud_) { + dMY_CXT; + PERL_CONTEXT *cx; + I32 cxix = MY_CXT.yield_storage.cxix; + I32 items = MY_CXT.yield_storage.items - 1; + SV **savesp = MY_CXT.yield_storage.savesp; + opcode type = OP_NULL; + U8 flags = 0; + OP *next; + + PERL_UNUSED_VAR(ud_); + + if (savesp) + PL_stack_sp = savesp; + + cx = cxstack + cxix; + switch (CxTYPE(cx)) { + case CXt_BLOCK: { + I32 i, cur = cxstack_ix, n = 1; + OP *o = NULL; + /* Is this actually a given/when block? This may occur only when yield was + * called with HERE (or nothing) as the context. */ +#if SU_HAS_PERL(5, 10, 0) + if (cxix > 0) { + PERL_CONTEXT *prev = cx - 1; + U8 type = CxTYPE(prev); + if ((type == CXt_GIVEN || type == CXt_WHEN) + && (prev->blk_oldcop == cx->blk_oldcop)) { + cxix--; + cx = prev; + if (type == CXt_GIVEN) + goto cxt_given; + else + goto cxt_when; + } + } +#endif + type = OP_LEAVE; + next = NULL; + /* Bare blocks (that appear as do { ... } blocks, map { ... } blocks or + * constant folded blcoks) don't need to save the op to return to anywhere + * since 'last' isn't supposed to work inside them. So we climb higher in + * the context stack until we reach a context that has a return op (i.e. a + * sub, an eval, a format or a real loop), recording how many blocks we + * crossed. Then we follow the op_next chain until we get to the leave op + * that closes the original block, which we are assured to reach since + * everything is static (the blocks we have crossed cannot be evals or + * subroutine calls). */ + for (i = cxix + 1; i <= cur; ++i) { + PERL_CONTEXT *cx2 = cxstack + i; + switch (CxTYPE(cx2)) { + case CXt_BLOCK: + ++n; + break; + case CXt_SUB: + case CXt_FORMAT: + o = SU_RETOP_SUB(cx2); + break; + case CXt_EVAL: + o = SU_RETOP_EVAL(cx2); + break; +#if SU_HAS_PERL(5, 11, 0) + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LAZYIV: +#else + case CXt_LOOP: +#endif + o = SU_RETOP_LOOP(cx2); + break; + } + if (o) + break; + } + if (!o) + o = PL_op; + while (n && o) { + /* We may find other enter/leave blocks on our way to the matching leave. + * Make sure the depth is incremented/decremented appropriately. */ + if (o->op_type == OP_ENTER) { + ++n; + } else if (o->op_type == OP_LEAVE) { + --n; + if (!n) { + next = o->op_next; + break; + } + } + o = o->op_next; + } + break; + } + case CXt_SUB: + case CXt_FORMAT: + type = OP_LEAVESUB; + next = SU_RETOP_SUB(cx); + break; + case CXt_EVAL: + type = CxTRYBLOCK(cx) ? OP_LEAVETRY : OP_LEAVEEVAL; + next = SU_RETOP_EVAL(cx); + break; +#if SU_HAS_PERL(5, 11, 0) + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LAZYIV: +#else + case CXt_LOOP: +#endif + type = OP_LEAVELOOP; + next = SU_RETOP_LOOP(cx); + break; +#if SU_HAS_PERL(5, 10, 0) + case CXt_GIVEN: +cxt_given: + type = OP_LEAVEGIVEN; + next = SU_RETOP_GIVEN(cx); + break; + case CXt_WHEN: +cxt_when: +#if SU_HAS_PERL(5, 15, 1) + type = OP_LEAVEWHEN; +#else + type = OP_BREAK; + flags |= OPf_SPECIAL; +#endif + next = NULL; + break; +#endif + case CXt_SUBST: + croak("yield() cannot target a substitution context"); + break; + default: + croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix)); + break; + } + + if (cxstack_ix > cxix) + dounwind(cxix); + + /* Hide the level */ + if (items >= 0) + PL_stack_sp--; + else + items = 0; + + /* Copy the arguments passed to yield() where the leave op expects to find + * them. */ + if (items) + Move(PL_stack_sp - items + 1, PL_stack_base + cx->blk_oldsp + 1, items, SV *); + PL_stack_sp = PL_stack_base + cx->blk_oldsp + items; + + flags |= OP_GIMME_REVERSE(cx->blk_gimme); + + MY_CXT.yield_storage.leave_op.op_type = type; + MY_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type]; + MY_CXT.yield_storage.leave_op.op_flags = flags; + MY_CXT.yield_storage.leave_op.op_next = next; + + PL_op = (OP *) &(MY_CXT.yield_storage.leave_op); + PL_op = PL_op->op_ppaddr(aTHX); + + MY_CXT.yield_storage.proxy_op.op_next = PL_op; + PL_op = &(MY_CXT.yield_storage.proxy_op); +} + /* --- Uplevel ------------------------------------------------------------- */ #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END @@ -1938,6 +2127,14 @@ STATIC void su_setup(pTHX) { MY_CXT.unwind_storage.proxy_op.op_type = OP_STUB; MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL; + Zero(&(MY_CXT.yield_storage.leave_op), 1, UNOP); + MY_CXT.yield_storage.leave_op.op_type = OP_STUB; + MY_CXT.yield_storage.leave_op.op_ppaddr = NULL; + + Zero(&(MY_CXT.yield_storage.proxy_op), 1, OP); + MY_CXT.yield_storage.proxy_op.op_type = OP_STUB; + MY_CXT.yield_storage.proxy_op.op_ppaddr = NULL; + MY_CXT.uplevel_storage.top = NULL; MY_CXT.uplevel_storage.root = NULL; MY_CXT.uplevel_storage.count = 0; @@ -2026,6 +2223,34 @@ XS(XS_Scope__Upper_unwind) { croak("Can't return outside a subroutine"); } +XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */ + +XS(XS_Scope__Upper_yield) { +#ifdef dVAR + dVAR; dXSARGS; +#else + dXSARGS; +#endif + dMY_CXT; + I32 cxix; + + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + + SU_GET_CONTEXT(0, items - 1, su_context_here()); + MY_CXT.yield_storage.cxix = cxix; + MY_CXT.yield_storage.items = items; + /* See XS_Scope__Upper_unwind */ + if (GIMME_V == G_SCALAR) { + MY_CXT.yield_storage.savesp = PL_stack_sp; + PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; + } else { + MY_CXT.yield_storage.savesp = NULL; + } + SAVEDESTRUCTOR_X(su_yield, NULL); + return; +} + MODULE = Scope::Upper PACKAGE = Scope::Upper PROTOTYPES: ENABLE @@ -2044,6 +2269,7 @@ BOOT: newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); + newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); su_setup(); } diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index f4d43e7..ac25417 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -170,7 +170,7 @@ localize variables, array/hash values or deletions of elements in higher context =item * -return values immediately to an upper level with L, and know which context was in use then with L ; +return values immediately to an upper level with L and L, and know which context was in use then with L ; =item * @@ -316,6 +316,30 @@ This means that will set C<$num> to C<'z'>. You can use L to handle these cases. +=head2 C + + yield; + yield @values, $context; + +Returns C<@values> I the context pointed by or just above C<$context>, and immediately restart the program flow at this point. +If C<@values> is empty, then the C<$context> parameter is optional and defaults to the current context ; otherwise it is mandatory. + +L differs from L in that it can target I upper scope (besides a C substitution context) and not necessarily a sub, an eval or a format. +Hence you can use it to return values from a C or a C block : + + my $now = do { + local $@; + eval { require Time::HiRes } or yield time() => HERE; + Time::HiRes::time(); + }; + + my @uniq = map { + yield if $seen{$_}++; # returns the empty list from the block + ... + } @things; + +Like for L, the upper context isn't coerced onto C<@values>. + =head2 C my $want = want_at; @@ -591,13 +615,14 @@ Where L, L and L act depending on t # $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP ... -Where L, L and L point to depending on the C<$cxt>: +Where L, L, L and L point to depending on the C<$cxt>: sub { eval { sub { { - unwind @things => $cxt; # or uplevel { ... } $cxt; + unwind @things => $cxt; # or yield @things => $cxt + # or uplevel { ... } $cxt ... } ... @@ -613,7 +638,7 @@ Where L, L and L point to depending on the C<$cxt>: =head1 EXPORT -The functions L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. +The functions L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. The constant L is also only exported on request, individually or by the tags C<':consts'> and C<':all'>. @@ -628,7 +653,8 @@ our %EXPORT_TAGS = ( funcs => [ qw< reap localize localize_elem localize_delete - unwind want_at + unwind yield + want_at uplevel uid validate_uid > ], diff --git a/t/01-import.t b/t/01-import.t index d27e6b9..dcd2525 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2 * 17; +use Test::More tests => 2 * 18; require Scope::Upper; @@ -13,6 +13,7 @@ my %syms = ( localize_elem => '$$$;$', localize_delete => '$$;$', unwind => undef, + yield => undef, want_at => ';$', uplevel => '&@', uid => ';$', diff --git a/t/55-yield-target.t b/t/55-yield-target.t new file mode 100644 index 0000000..594a04b --- /dev/null +++ b/t/55-yield-target.t @@ -0,0 +1,140 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 18; + +use Scope::Upper qw; + +my @res; + +@res = (0, eval { + yield; + 1; +}, 2); +is $@, '', 'yield() does not croak'; +is_deeply \@res, [ 0, 2 ], 'yield() in eval { ... }'; + +@res = (3, eval " + yield; + 4; +", 5); +is $@, '', 'yield() does not croak'; +is_deeply \@res, [ 3, 5 ], 'yield() in eval "..."'; + +@res = (6, sub { + yield; + 7; +}->(), 8); +is_deeply \@res, [ 6, 8 ], 'yield() in sub { ... }'; + +@res = (9, do { + yield; + 10; +}, 11); +is_deeply \@res, [ 9, 11 ], 'yield() in do { ... }'; + +@res = (12, (map { + yield; + 13; +} qw), 14); +is_deeply \@res, [ 12, 14 ], 'yield() in map { ... }'; + +my $loop; +@res = (15, do { + for (16, 17) { + $loop = $_; + yield; + my $x = 18; + } +}, 19); +is $loop, 16, 'yield() exited for'; +is_deeply \@res, [ 15, 19 ], 'yield() in for () { ... }'; + +@res = (20, do { + $loop = 21; + while ($loop) { + yield; + $loop = 0; + my $x = 22; + } +}, 23); +is $loop, 21, 'yield() exited while'; +is_deeply \@res, [ 20, 23 ], 'yield() in while () { ... }'; + +{ + my $s = 'a'; + local $@; + eval { + $s =~ s/./yield; die 'not reached'/e; + }; + my $err = $@; + my $line = __LINE__-3; + like $err, + qr/^yield\(\) cannot target a substitution context at \Q$0\E line $line/, + 'yield() cannot exit subst'; +} + +SKIP: { + skip 'perl 5.10 is required to test interaction with given/when' => 6 + if "$]" < 5.010; + + @res = eval <<'TESTCASE'; + use feature 'switch'; + (24, do { + given (25) { + yield; + my $x = 26; + } + }, 27); +TESTCASE + diag $@ if $@; + is_deeply \@res, [ 24, 27 ], 'yield() in given { }'; + + # Beware that calling yield() in when() in given() sends us directly at the + # end of the enclosing given block. + @res = (); + eval <<'TESTCASE'; + use feature 'switch'; + @res = (28, do { + given (29) { + when (29) { + yield; + die 'not reached 1'; + } + die 'not reached 2'; + } + }, 30) +TESTCASE + is $@, '', 'yield() in when { } in given did not croak'; + is_deeply \@res, [ 28, 30 ], 'yield() in when { } in given'; + + # But calling yield() in when() in for() sends us at the next iteration. + @res = (); + eval <<'TESTCASE'; + use feature 'switch'; + @res = (31, do { + for (32, 33) { + $loop = $_; + when (32) { + yield; + die 'not reached 3'; + my $x = 34; + } + when (33) { + yield; + die 'not reached 4'; + my $x = 35; + } + die 'not reached 5'; + my $x = 36; + } + }, 37) +TESTCASE + is $@, '', 'yield() in for { } in given did not croak'; + is $loop, 33, 'yield() exited for on the second iteration'; + # A loop exited by last() evaluates to an empty list, but a loop that reached + # its natural end evaluates to false! + is_deeply \@res, [ 31, '', 37 ], 'yield() in when { }'; +} diff --git a/t/57-yield-context.t b/t/57-yield-context.t new file mode 100644 index 0000000..9b59624 --- /dev/null +++ b/t/57-yield-context.t @@ -0,0 +1,266 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 33; + +use Scope::Upper qw; + +my ($res, @res); + +# --- Void to void ------------------------------------------------------------ + +do { + $res = 1; + yield(qw => HERE); + $res = 0; +}; +ok $res, 'yield in void context at sub to void'; + +do { + $res = 1; + eval { + yield(qw => SCOPE(1)); + }; + $res = 0; +}; +ok $res, 'yield in void context at sub across eval to void'; + +do { + $res = 1; + for (1 .. 5) { + yield qw => SCOPE(1); + } + $res = 0; +}; +ok $res, 'yield in void context at sub across loop to void'; + +# --- Void to scalar ---------------------------------------------------------- + +$res = do { + yield(qw => HERE); + return 'XXX'; +}; +is $res, 'c', 'yield in void context at sub to scalar'; + +$res = do { + eval { + yield qw => SCOPE(1); + }; + return 'XXX'; +}; +is $res, 'f', 'yield in void context at sub across eval to scalar'; + +$res = do { + for (1 .. 5) { + yield qw => SCOPE(1); + } +}; +is $res, 'i', 'yield in void context at sub across loop to scalar'; + +$res = do { + for (6, yield qw => SCOPE(0)) { + $res = 'NO'; + } + 'XXX'; +}; +is $res, 'l', 'yield in void context at sub across loop iterator to scalar'; + +# --- Void to list ------------------------------------------------------------ + +@res = do { + yield qw => HERE; + return 'XXX'; +}; +is_deeply \@res, [ qw ], 'yield in void context at sub to list'; + +@res = do { + eval { + yield qw => SCOPE(1); + }; + 'XXX'; +}; +is_deeply \@res, [ qw ], 'yield in void context at sub across eval to list'; + +@res = do { + for (1 .. 5) { + yield qw => SCOPE(1); + } +}; +is_deeply \@res, [ qw ], 'yield in void context at sub across loop to list'; + +# --- Scalar to void ---------------------------------------------------------- + +do { + $res = 1; + my $temp = yield(qw => HERE); + $res = 0; +}; +ok $res, 'yield in scalar context at sub to void'; + +do { + $res = 1; + my $temp = eval { + yield(qw => SCOPE(1)); + }; + $res = 0; +}; +ok $res, 'yield in scalar context at sub across eval to void'; + +do { + $res = 1; + for (1 .. 5) { + my $temp = (yield qw => SCOPE(1)); + } + $res = 0; +}; +ok $res, 'yield in scalar context at sub across loop to void'; + +do { + $res = 1; + if (yield qw => SCOPE(0)) { + $res = undef; + } + $res = 0; +}; +ok $res, 'yield in scalar context at sub across test to void'; + +# --- Scalar to scalar -------------------------------------------------------- + +$res = sub { + 1, yield(qw => HERE); +}->(0); +is $res, 'c', 'yield in scalar context at sub to scalar'; + +$res = sub { + eval { + 8, yield qw => SCOPE(1); + }; +}->(0); +is $res, 'f', 'yield in scalar context at sub across eval to scalar'; + +$res = sub { + if (yield qw => SCOPE(0)) { + return 'XXX'; + } +}->(0); +is $res, 'o', 'yield in scalar context at sub across test to scalar'; + +# --- Scalar to list ---------------------------------------------------------- + +@res = sub { + if (yield qw => SCOPE(0)) { + return 'XXX'; + } +}->(0); +is_deeply \@res, [ qw ], 'yield in scalar context at sub across test to list'; + +# --- List to void ------------------------------------------------------------ + +do { + $res = 1; + my @temp = yield(qw => HERE); + $res = 0; +}; +ok $res, 'yield in list context at sub to void'; + +do { + $res = 1; + my @temp = eval { + yield(qw => SCOPE(1)); + }; + $res = 0; +}; +ok $res, 'yield in list context at sub across eval to void'; + +do { + $res = 1; + for (1 .. 5) { + my @temp = (yield qw => SCOPE(1)); + } + $res = 0; +}; +ok $res, 'yield in list context at sub across loop to void'; + +do { + $res = 1; + for (6, yield qw => SCOPE(0)) { + $res = undef; + } + $res = 0; +}; +ok $res, 'yield in list context at sub across test to void'; + +# --- List to scalar ---------------------------------------------------------- + +$res = do { + my @temp = (1, yield(qw => HERE)); + 'XXX'; +}; +is $res, 'c', 'yield in list context at sub to scalar'; + +$res = do { + my @temp = eval { + 8, yield qw => SCOPE(1); + }; + 'XXX'; +}; +is $res, 'f', 'yield in list context at sub across eval to scalar'; + +$res = do { + for (1 .. 5) { + my @temp = (7, yield qw => SCOPE(1)); + } + 'XXX'; +}; +is $res, 'i', 'yield in list context at sub across loop to scalar'; + +$res = sub { + for (6, yield qw => SCOPE(0)) { + return 'XXX'; + } +}->(0); +is $res, 'l', 'yield in list context at sub across loop iterator to scalar'; + +# --- List to list ------------------------------------------------------------ + +@res = do { + 2, yield qw => HERE; +}; +is_deeply \@res, [ qw ], 'yield in list context at sub to list'; + +@res = do { + eval { + 8, yield qw => SCOPE(1); + }; +}; +is_deeply \@res, [ qw ], 'yield in list context at sub across eval to list'; + +@res = sub { + for (6, yield qw => SCOPE(0)) { + return 'XXX'; + } +}->(0); +is_deeply \@res, [ qw ], 'yield in list context at sub across loop iterator to list'; + +# --- Prototypes -------------------------------------------------------------- + +sub pie { 7, yield qw, $_[0] => SUB } + +sub wlist (@) { return @_ } + +$res = wlist pie 1; +is $res, 3, 'yield to list prototype to scalar'; + +@res = wlist pie 2; +is_deeply \@res, [ qw ], 'yield to list prototype to list'; + +sub wscalar ($$) { return @_ } + +$res = wscalar pie(6), pie(7); +is $res, 2, 'yield to scalar prototype to scalar'; + +@res = wscalar pie(8), pie(9); +is_deeply \@res, [ 8, 9 ], 'yield to scalar prototype to list'; + diff --git a/t/58-yield-misc.t b/t/58-yield-misc.t new file mode 100644 index 0000000..23fc1d4 --- /dev/null +++ b/t/58-yield-misc.t @@ -0,0 +1,76 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 4 * 3; + +use lib 't/lib'; +use VPIT::TestHelpers; + +use Scope::Upper qw; + +# Test timely destruction of values returned from yield() + +our $destroyed; +sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) } + +{ + my $desc = 'scalar context, above'; + local $destroyed; + { + my $obj = guard(); + my $res = do { + is $destroyed, undef, "$desc: not yet destroyed 1"; + yield $obj => HERE; + fail 'not reached 1'; + }; + is $destroyed, undef, "$desc: not yet destroyed 2"; + } + is $destroyed, 1, "$desc: destroyed 1"; +} + +{ + my $desc = 'scalar context, below'; + local $destroyed; + { + my $res = do { + my $obj = guard(); + is $destroyed, undef, "$desc: not yet destroyed 1"; + yield $obj => HERE; + fail 'not reached 1'; + }; + is $destroyed, undef, "$desc: not yet destroyed 2"; + } + is $destroyed, 1, "$desc: destroyed 1"; +} + +{ + my $desc = 'void context, above'; + local $destroyed; + { + my $obj = guard(); + { + is $destroyed, undef, "$desc: not yet destroyed 1"; + yield $obj => HERE; + fail 'not reached 1'; + } + is $destroyed, undef, "$desc: not yet destroyed 2"; + } + is $destroyed, 1, "$desc: destroyed 1"; +} + +{ + my $desc = 'void context, below'; + local $destroyed; + { + { + is $destroyed, undef, "$desc: not yet destroyed 1"; + my $obj = guard(); + yield $obj => HERE; + fail 'not reached 2'; + } + is $destroyed, 1, "$desc: destroyed 1"; + } + is $destroyed, 1, "$desc: destroyed 2"; +} diff --git a/t/59-yield-threads.t b/t/59-yield-threads.t new file mode 100644 index 0000000..fbe054f --- /dev/null +++ b/t/59-yield-threads.t @@ -0,0 +1,46 @@ +#!perl -T + +use strict; +use warnings; + +use lib 't/lib'; +use Scope::Upper::TestThreads; + +use Test::Leaner; + +use Scope::Upper qw; + +our $z; + +sub up1 { + my $tid = threads->tid(); + local $z = $tid; + my $p = "[$tid] up1"; + + usleep rand(1e6); + + my @res = ( + -1, + do { + my @dummy = ( + 999, + map { + my $foo = yield $tid .. $tid + 2 => UP; + fail "$p: not reached"; + } 666 + ); + fail "$p: not reached"; + }, + -2 + ); + + is_deeply \@res, [ -1, $tid .. $tid + 2, -2 ], "$p: yielded correctly"; +} + +my @threads = map spawn(\&up1), 1 .. 30; + +$_->join for @threads; + +pass 'done'; + +done_testing(scalar(@threads) + 1); diff --git a/t/85-stress-yield.t b/t/85-stress-yield.t new file mode 100644 index 0000000..7d9fe5a --- /dev/null +++ b/t/85-stress-yield.t @@ -0,0 +1,148 @@ +#!perl -T + +use strict; +use warnings; + +use lib 't/lib'; +use Test::Leaner 'no_plan'; + +use Scope::Upper qw; + +# @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in +# scalar context on perl 5.8.5 and below. + +sub list { wantarray ? @_ : $_[$#_] } + +my @blocks = ( + [ + 'do {', + '}' + ], + [ + '(list map {', # map in scalar context yields the number of elements + '} 1)' + ], + [ + 'sub { + my $next = shift;', + '}->($next, @_)' + ], + [ + 'eval {', + '}' + ], +); + +my @contexts = ( + [ '', '; ()', 'v' ], + [ 'scalar(', ')', 's' ], + [ 'list(', ')', 'l' ], +); + +sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ } + +our @stack; +our @pre; + +# Don't put closures in empty pads on 5.6. + +my $dummy; +my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : ''; + +my @test_frames; + +for my $block (@blocks) { + for my $context (@contexts) { + my $source = <<"FRAME"; + sub { + my \$next = shift; $capture_outer_pad + $block->[0] + unshift \@stack, HERE; + $context->[0] + (\@{shift \@pre}, \$next->[0]->(\@_)) + $context->[1] + $block->[1] + } +FRAME + my $code; + { + local $@; + $code = do { + no warnings 'void'; + eval $source; + }; + my $err = $@; + chomp $err; + die "$err. Source was :\n$source\n" if $@; + } + push @test_frames, [ $code, $source, $context->[2] ]; + } +} + +my @targets = ( + [ sub { + my $depth = pop; + unshift @stack, HERE; + yield(@_ => $stack[$depth]); + }, 'target context from HERE' ], + [ sub { + my $depth = pop; + yield(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1))); + }, 'target context from SCOPE' ], +); + +my $seed = 0; + +for my $args ([ ], [ 'A' ], [ qw ]) { + my @args = @$args; + for my $frame0 (@test_frames) { + for my $frame1 (@test_frames) { + for my $frame2 (@test_frames) { + my $max_depth = 3; + $seed += 5; # Coprime with $max_depth + my @prepend; + for (1 .. $max_depth) { + ++$seed; + my $i = $seed + $_; + my $l = $seed % $max_depth - 1; + push @prepend, [ $i .. ($i + $l) ]; + } + my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend; + for my $depth (0 .. $max_depth) { + my $exp = do { + my @cxts = map $_->[2], $frame0, $frame1, $frame2; + my @exp = @args; + for (my $i = $depth + 1; $i <= $max_depth; ++$i) { + my $c = $cxts[$max_depth - $i]; + if ($c eq 'v') { + @exp = (); + } elsif ($c eq 's') { + @exp = @exp ? $exp[-1] : undef; + } else { + unshift @exp, @{$prepend[$max_depth - $i]}; + } + } + linearize @exp; + }; + for my $target (@targets) { + local @stack; + local @pre = @prepend; + my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth); + my $got = linearize @res; + if ($got ne $exp) { + diag <[1] +$frame1->[1] +$frame2->[1] +$target->[1] +==== vvvvv Errors vvvvvv === +DIAG + } + is $got, $exp, "yield to depth $depth with args [@args] and prepending $prepend_str"; + } + } + } + } + } +}