Permalink
Browse files

implement winner syntax and WINNER sub.

  • Loading branch information...
1 parent 087165f commit b76c38cd73cf3b3db55e10c3157e31b3e6eb1fae @timo timo committed Nov 18, 2013
Showing with 154 additions and 41 deletions.
  1. +61 −0 src/Perl6/Actions.nqp
  2. +5 −0 src/Perl6/Grammar.nqp
  3. +88 −41 src/vm/jvm/core/asyncops.pm
View
@@ -1225,6 +1225,67 @@ class Perl6::Actions is HLL::Actions does STDActions {
make when_handler_helper($<block>.ast);
}
+ method statement_control:sym<winner>($/) {
+ my @inner_statements;
+ if $<xblock> {
+ @inner_statements := $<xblock><pblock><blockoid><statementlist><statement>;
+ } elsif $<block> {
+ @inner_statements := $<block><blockoid><statementlist><statement>;
+ }
+ my $wild_done;
+ my $wild_more;
+ my $later;
+
+ my $past := QAST::Op.new( :op('call'), :name('&WINNER'), :node($/) );
+ if $<xblock> {
+ $past.push( $<xblock><EXPR>.ast );
+ } elsif $<block> {
+ $past.push( QAST::Op.new(
+ :op('callmethod'),
+ :name('new'),
+ QAST::WVal.new( :value($*W.find_symbol(['List'])) ) ));
+ }
+
+ # TODO verify that the inner block only has more/done/later blocks in it
+ for @inner_statements -> $/ {
+ if $<statement_control> -> $/ {
+ if $<sym> eq 'done' || $<sym> eq 'more' {
+ if $<sym> eq 'done' {
+ if nqp::istype($<xblock><EXPR>.ast.returns, $*W.find_symbol(['Whatever'])) {
+ # TODO error
+ $wild_done := block_closure($<xblock><pblock>.ast);
+ $wild_done.named('wild_done');
+ } else {
+ $past.push(QAST::IVal.new(:value(0))); # "DONE"
+ $past.push($<xblock><EXPR>.ast);
+ $past.push(block_closure($<xblock><pblock>.ast));
+ }
+ } elsif $<sym> eq 'more' {
+ if nqp::istype($<xblock><EXPR>.ast.returns, $*W.find_symbol(['Whatever'])) {
+ $wild_more := block_closure($<xblock><pblock>.ast);
+ $wild_more.named('wild_more');
+ } else {
+ $past.push(QAST::IVal.new(:value(1))); # "MORE"
+ $past.push($<xblock><EXPR>.ast);
+ $past.push(block_closure($<xblock><pblock>.ast));
+ }
+ }
+ } elsif $<sym> eq 'later' {
+ # TODO error
+ $later := block_closure($<block>.ast);
+ $later.named('later');
+ }
+ } else {
+ # TODO error
+ }
+ }
+ if $wild_done { $past.push( $wild_done ) }
+ if $wild_more { $past.push( $wild_more ) }
+ if $later { $past.push( $later ) }
+
+ make $past;
+ }
+
method statement_control:sym<CATCH>($/) {
if nqp::existskey(%*HANDLERS, 'CATCH') {
$*W.throw($/, ['X', 'Phaser', 'Multiple'], block => 'CATCH');
View
@@ -1386,6 +1386,11 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
<sym><.end_keyword> <block>
}
+ token statement_control:sym<winner> { <sym> <.ws> [<?before '{'> <block>|<xblock>] }
+ token statement_control:sym<more> { <sym> <.ws> <xblock(1)> }
+ token statement_control:sym<done> { <sym> <.ws> <xblock(1)> }
+ token statement_control:sym<later> { <sym> <.ws> <block> }
+
rule statement_control:sym<CATCH> {<sym> <block(1)> }
rule statement_control:sym<CONTROL> {<sym> <block(1)> }
View
@@ -14,51 +14,98 @@ multi sub await(Channel $c) {
$c.receive
}
-# Takes a list of pairs, mapping a Channel or Promise to code. Invokes the
-# code block of whichever Channel receives first whichever Promise is kept
-# or broken first. Evaluates to the result of that code block.
-# If none of the channels have a value or none of the promises have a result,
-# then the default block is ran. If there is no default block, winner() blocks
-# until one channel or promise is ready.
-# If more than one channel/promise is ready, winner() picks one at random
+my constant $WINNER_KIND_DONE = 0;
+my constant $WINNER_KIND_MORE = 1;
-proto sub winner(|) { * }
-multi sub winner(*@contestants, :$default) {
- multi is-ready(Promise $contestant) {
- if $contestant {
- return (True, $contestant)
+sub WINNER(@winner_args, *@pieces, :$wild_done, :$wild_more, :$later) {
+ my Int $num_pieces = +@pieces div 3;
+ sub invoke_right(&block, $key, $value?) {
+ my @names = map *.name, &block.signature.params;
+ return do if @names eqv ['$k', '$v'] || @names eqv ['$v', '$k'] {
+ &block(:k($key), :v($value));
+ } elsif @names eqv ['$_'] {
+ &block($value);
+ } elsif @names eqv ['$k'] {
+ &block(:k($key));
+ } elsif @names eqv ['$v'] {
+ &block(:v($value));
+ } elsif +@names == 0 {
+ return &block();
+ } else {
+ die "couldn't figure out how to invoke {&block.signature().perl}";
}
- return (False, False)
}
-
- multi is-ready(Channel $c) {
- my $contestant is default(Nil) = $c.poll;
- unless $contestant === Nil {
- return (True, $contestant)
- }
- return (False, False)
- }
- multi is-ready(Any $c) {
- die "Cannot use winner on a " ~ .^name;
- }
-
- if @contestants.grep: { $_ !~~ Pair } {
- die "winner() expects to be passed a list of pairs";
- }
-
- my $winner;
+ # if we don't have a last block, we need to retry until we
+ # have a winner.
loop {
- for @contestants.pick(+@contestants) -> $contestant {
- next unless (my $arg = is-ready($contestant.key))[0];
-
- $winner = $contestant.value => $arg[1];
- last;
+ my @promises_only;
+ my Bool $has_channels = False;
+ if $num_pieces > 0 {
+ for (^$num_pieces).pick(*) -> $index {
+ my ($kind, $arg, &block) = @pieces[$index * 3, $index * 3 + 1, $index * 3 + 2];
+ if $kind == $WINNER_KIND_DONE {
+ if $arg ~~ Promise {
+ if $arg {
+ return invoke_right(&block, $arg, $arg.result);
+ }
+ @promises_only.push: $arg;
+ } elsif $arg ~~ Channel {
+ if $arg.closed {
+ return invoke_right(&block, $arg);
+ }
+ $has_channels = True;
+ } else {
+ die "Got a {$arg.WHAT.perl}, but expected a Channel or Promise.";
+ }
+ } elsif $kind == $WINNER_KIND_MORE {
+ if $arg ~~ Channel {
+ if (my $val := $arg.poll) !~~ Nil {
+ return invoke_right(&block, $arg, $val);
+ }
+ $has_channels = True;
+ } elsif $arg ~~ Promise {
+ die "cannot use 'more' on a Promise.";
+ } else {
+ die "Got a {$arg.WHAT.perl}, but expected a Channel or Promise.";
+ }
+ }
+ }
+ if $later {
+ return $later();
+ }
+ } else {
+ for @winner_args.pick(*) {
+ when Channel {
+ if (my $val := $_.poll()) !~~ Nil {
+ return invoke_right($wild_more, $_, $val);
+ } elsif $_.closed.has_value {
+ return $wild_done(:k($_));
+ }
+ $has_channels = True;
+ }
+ when Promise {
+ if $_ {
+ return invoke_right($wild_done, $_, $_.result);
+ }
+ @promises_only.push: $_;
+ }
+ default {
+ die "Got a {$_.WHAT.perl}, but expected a Channel or Promise.";
+ }
+ }
+ # when we hit this, none of the promises or channels
+ # have given us a result. if we have a later closure,
+ # we immediately return, otherwise we block on any
+ # of the promises of our args.
+ if $later {
+ return $later();
+ }
+ # if we only had promises, we can block on "anyof".
+ }
+ if $has_channels {
+ Thread.yield();
+ } else {
+ Promise.anyof(@promises_only).result;
}
- last if $winner //= $default;
-
- Thread.yield;
}
- nqp::istype($winner, Pair)
- ?? $winner.key.($winner.value)
- !! $winner.()
}

0 comments on commit b76c38c

Please sign in to comment.