Coroutine.pm

Code Index:

NAME

EulerMB::Coroutine

SYNOPSIS

 use EulerMB::Coroutine qw(:all);
 sub gen_func
 {
     my $x = 0;
     return coroutine {
         COBEGIN();
         while($x < 10) {
             YIELD($x);
             $x++;
         }
     }->wrap();
 }
 
 my $func = &gen_func();
 while(my @x = $func->()) {
     print "$x[0]\n";
 }
 # prints 0..9

DESCRIPTION

This module simulates the semi-coroutine (asymmetric coroutine / Python generator) language contruct in pure Perl.

Simply, a ``semi-coroutine'' is a subroutine that suspends itself in the middle of execution, returns a value, can be resumed at the same point of execution at a later time.

More completely, a semi-coroutine is a limited form of coroutine. See Programming in Lua : 9.1 - Coroutine Basics http://www.lua.org/pil/9.1.html, Python PEP 255: Simple Generators http://www.python.org/peps/pep-0255.html, Continuations and Coroutines http://c2.com/cgi/wiki, http://www.akira.ruc.dk/~keld/research/COROUTINE/COROUTINE-1.0/DOC/COROUTINE_REPORT.pdf, http://www.inf.puc-rio.br/~roberto/docs/corosblp.pdf, http://www.chiark.greenend.org.uk/~sgtatham/coroutines.html .

IMPLEMENTATION

Coroutines can be simulated with some success in languages without native support by using goto and label tricks. See for example, ``Coroutines in C'' http://www.chiark.greenend.org.uk/~sgtatham/coroutines.html

This module simulates semi-coroutines in Perl gotos and labels. The details are abstracted away in a few functions and a small amount of (optional) source filtering.

For an alternative implementation of coroutines in Perl, see Coro::Cont. As of v. 1.0a, Coro::Cont tends to segfault if not handled with much caution, and there can be some portability concerns or issues, especially when threading is enabled. EulerMB::Coroutines is intended to simpler solution that more portable, but it is also more of an ad-hoc solution than Coro::Cont.

LIMITATIONS AND CAVEATS

Lexicals are not preserved across yields:

 sub func {
     COBEGIN();
     for(my $n=0; $n < 10; $n++) {
         YIELD($n); # $n always zero or undef
     }
 }
 sub func {
     COBEGIN();
     while($x =~ /(.)/g) {
         YIELD($1);
         print $1;  # may have been overwritten
     }
 }

A solution to put all lexical variables that could be lost into a closure:

  sub gen_func {
     my $n;
     return coroutine {
         COBEGIN();
         for(my $n=0; $n<10; $n++) {
             YEILD($n);
         }
     }->wrap();
 }
 my $func = &gen_func();

You cannot yield within a foreach loop since perl does not allow

 goto L1;
 for my $val (@vals) {
   L1:
 }

but dies with ``Can't ''goto`` into the middle of a foreach loop at t10.pl line 1.''

The workaround is to use a for loop, where the counter is saved in the closure:

 sub gen_func {
     my $n;
     return coroutine {
         COBEGIN();
         for(my $n=0; $n<@vals; $n++) {
             YEILD($n);
         }
     }->wrap();
 }

It is ok for a coroutine to call other functions. However, those other functions may not yield unless called using a special convention:

 sub func
 {
     COBEGIN();
     YIELD(1);
     CALL(\&func2);
     YIELD(2);
 }
 sub func2
 {
     COBEGIN();
     YIELD(3);
     YIELD(4);
 }

Pass any function parameters to the constructor for a closure:

 sub func
 {
     COBEGIN();
     YIELD(1);
     my $func2 = &get_func2('test');
     CALL($func2);
     CALL($func2);
     YIELD(2);
 }
 sub gen_func2
 {
     my($value) = @_;
     return sub {
         COBEGIN();
         YIELD(3);
         print $value; 
         YIELD(4);
     };
 }

Currently, the YIELD always returns a list. FIX-TODO-allow handling other contexts in return value.

Functions

coroutine
Constructs a new coroutine, passing in a coderef. 
 my $coroutine = coroutine {
     COBEGIN();
     # ...
 };

Coroutine Methods

wrap
Returns a reference to a closure that when called, resumes the coroutine. This is similar to the ``wrap'' method in Lua coroutines. 
  my $func = $coroutine->wrap();
  print $func->();
  print $func->();
  print $func->();

MACROS

YIELD
Suspends the current coroutine and returns a value.

CALL
Calls a subroutine from a coroutine, where the subroutine itself can YIELD.

COBEGIN
Performs initialization code (jumps). This must be placed at the beginning of each coroutine or subroutine called using the CALL macro.

Dependencies

Exporter, Filter::Simple

COPYRIGHT

(c) 1998-2004, David Manura. http://math2.org/david/contact. This module is licensed under the same terms as Perl itself.

package EulerMB::Coroutine;
use strict;
use Exporter;
use base 'Exporter';
use Filter::Simple;
#use EulerMB::Debug;

our $VERSION = '1.00';

our @EXPORT_OK = qw(coroutine);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);


sub new
{
    my($class, $sub) = @_;
    my $self = bless {}, $class;
    %$self = (
        stack => [[$sub, undef]]
    );
    return $self;
}

sub wrap
{
    my($self) = @_;
    my $wrap = sub {
        &schedule($self, undef);
    };
    return $wrap;
}


#FIX:support return value?
sub call
{
    my($from_label, $to_sub) = @_;
    return bless [$from_label, $to_sub], __PACKAGE__.'::Call';
}

sub yield
{
    my($from_label, $retval) = @_;
    return bless [$from_label, $retval], __PACKAGE__.'::Yield';
}


sub coroutine(&)
{
    my($sub) = @_;
    return __PACKAGE__->new($sub);
}


sub schedule
{
    my($codata, $from_label) = @_;

    my $costack = $codata->{stack};

    while(1) {
#	print Data::Dumper::Dumper($costack);
        my $top = $costack->[@$costack-1];
        my($to_sub, $to_label) = @$top;

	return if ! defined $to_sub;

        my @ret;
        eval {
            @ret = $to_sub->($to_label);  #FIX:or pass via $_ ?
        };
        my $err = $@;
	if($err) {
	    @$costack = (); die $err;
	}
	if(ref($ret[0]) eq __PACKAGE__.'::Call') {
	    $costack->[@$costack-1]->[1] = $ret[0]->[0];
	    push @$costack, [$ret[0]->[1], undef];
	}
	elsif(ref($ret[0]) eq __PACKAGE__.'::Yield') {
            $costack->[@$costack-1]->[1] = $ret[0]->[0];
	    return @{$ret[0]->[1]};
	}
	else { # end of sub
            pop @$costack;
            # note: return value in "return" not currently supported.
            # FIX?
	    return if @$costack == 0;
	}
    }
}


FILTER {
    my $label = 0;
    my $levelN;
    # friedl, p.330
    $levelN = qr/ (?> [^()]+ | \( (??{ $levelN }) \) )* /x;
    my $package = __PACKAGE__;
    s{YIELD(\($levelN\))}{
		$label++;
                qq( do { return ${package}::yield("CO$label", [$1]); CO$label: } )
        }gse;
    s{CALL(\($levelN\))}{
		$label++;
                qq( do { return ${package}::call("CO$label", $1); CO$label: } )
        }gse;
    s{COBEGIN\(\)}{
                qq( do { my \$label = shift; goto \$label if defined \$label; } )
        }gse;

    #open(my $fh, '>Coroutine_out.pm') or die $!; print $fh $_;
    #die $_; # DEBUG
}

__END__