Coro-6.57/0000755000000000000000000000000013710272364011060 5ustar rootrootCoro-6.57/t/0000755000000000000000000000000013710272364011323 5ustar rootrootCoro-6.57/t/18_winder.t0000644000000000000000000000105611121473704013305 0ustar rootroot$|=1; print "1..17\n"; no warnings; use Coro; my @enter = (3, 8, 12, -1); my @leave = (6, 10, 14, -1); async { print "ok 2\n"; { Coro::on_enter { print "ok ", shift @enter, "\n"; }; print "ok 4\n"; Coro::on_leave { print "ok ", shift @leave, "\n"; }; print "ok 5\n"; cede; print "ok 9\n"; cede; print "ok 13\n"; } print "ok 15\n"; $cb = Coro::rouse_cb; print "ok 16\n"; }; print "ok 1\n"; cede; print "ok 7\n"; cede; print "ok 11\n"; cede; print "ok 17\n"; Coro-6.57/t/16_signal.t0000644000000000000000000000243611220312366013267 0ustar rootroot$|=1; print "1..18\n"; no warnings; use Coro; use Coro::Signal; { my $sig = new Coro::Signal; $as1 = async { my $g = $sig->wait; print "ok 3\n"; }; $as2 = async { my $g = $sig->wait; print "ok 4\n"; }; cede; # put 1, 2 in wait q $as3 = async { my $g = $sig->wait; print "ok 2\n"; }; $as4 = async { my $g = $sig->wait; print "ok 6\n"; }; $as5 = async { my $g = $sig->wait; print "ok 9\n"; }; $sig->send; # ready 1 $sig->send; # ready 2 $sig->send; # remember print +(Coro::Semaphore::count $sig) == 1 ? "" : "not ", "ok 1\n"; cede; # execute 3 (already ready, no contention), 1, 2 print +(Coro::Semaphore::count $sig) == 0 ? "" : "not ", "ok 5\n"; $sig->send; cede; print +(Coro::Semaphore::count $sig) == 0 ? "" : "not ", "ok 7\n"; $sig->broadcast; print +(Coro::Semaphore::count $sig) == 0 ? "" : "not ", "ok 8\n"; cede; $sig->wait (sub { print "ok 12\n" }); print "ok 10\n"; print "ok 11\n"; $sig->send; print "ok 13\n"; cede; print "ok 14\n"; $sig->send; print "ok 15\n"; $sig->wait (sub { print "ok 16\n" }); print "ok 17\n"; print +(Coro::Semaphore::count $sig) == 0 ? "" : "not ", "ok 18\n"; } Coro-6.57/t/01_process.t0000644000000000000000000000154011563071420013460 0ustar rootroot$|=1; print "1..13\n"; use Coro; async { print "ok 2\n"; }; print "ok 1\n"; cede; print "ok 3\n"; my $c1 = async { print "ok 5\n"; cede; print "not ok 8\n";#d# }; print $c1->ready ? "not " : "", "ok 4\n"; cede; print "ok 6\n"; $c1->on_destroy (sub { print "ok 7\n"; }); $c1->cancel; print "ok 8\n"; cede; cede; print "ok 9\n"; { my $as1 = async { print "not ok 10\n"; }; my $as2 = async { print "ok 10\n"; $as1->cancel; }; $as2->cede_to; } { my $as1 = async { print "not ok 11\n"; }; my $as2 = async { print "ok 11\n"; $as1->cancel; cede; print "ok 12\n"; $Coro::main->ready; $Coro::main->throw ("exit"); }; local $SIG{__DIE__} = sub { print "ok 13\n"; exit if $@ eq "exit"; }; $as2->schedule_to; } print "not ok 12\n"; Coro-6.57/t/19_handle.t0000644000000000000000000000177511233456245013266 0ustar rootrootBEGIN { unless (exists $SIG{USR1}) { print <autoflush(1); async { $W->print("one\ntwo\n\nthree\n\n\nfour\n\n\nfive\nsix\nseven"); $W->close; } my $p; while (defined(my $i = $R->readline($sep[$c]))) { $p .= $i . ":"; } $ex[$c] eq $p or print "not "; print "ok " . (1 + $c) . "\n"; } Coro-6.57/t/13_diewarn.t0000644000000000000000000000113210704467461013445 0ustar rootrootBEGIN { $| = 1; print "1..7\n"; } use Coro; use Coro::State; print "ok 1\n"; async { warn "-"; cede; warn "-"; local $SIG{__WARN__} = sub { print "ok 7\n" }; { local $SIG{__WARN__} = sub { print "ok 5\n" }; cede; warn "-"; } cede; warn "-"; cede; }; async { $Coro::State::WARNHOOK = sub { print "ok 3\n" }; local $SIG{__WARN__} = sub { print "ok 6\n" }; { local $SIG{__WARN__} = sub { print "ok 4\n" }; cede; warn "-"; } cede; warn "-"; }; $Coro::State::WARNHOOK = sub { print "ok 2\n" }; cede; cede; cede; cede; Coro-6.57/t/06_prio.t0000644000000000000000000000100210531710372012751 0ustar rootroot$|=1; print "1..10\n"; use Coro qw(:prio cede async current); print "ok 1\n"; use Carp; $SIG{__DIE__} = sub { Carp::cluck $@ };#d# (async { print "ok 2\n"; cede; cede; cede; print "ok 3\n" })->prio(10); (async { print "ok 4\n" })->prio(2); (async { print "ok 5\n" })->prio(PRIO_HIGH); (async { print "ok 6\n" }); (async { print "ok 7\n" })->prio(PRIO_LOW); (async { print "ok 8\n" })->prio(PRIO_IDLE); (async { print "ok 9\n"; cede; print "ok 11\n" })->prio(-500); current->prio(-100); cede; print "ok 10\n"; Coro-6.57/t/00_basic.t0000644000000000000000000000137610700736505013075 0ustar rootrootBEGIN { $| = 1; print "1..9\n"; } END {print "not ok 1\n" unless $loaded;} use Coro::State; $loaded = 1; print "ok 1\n"; my $main = new Coro::State; my $proca = new Coro::State \&a; my $procb = new Coro::State \&b; sub a { print $/ eq "\n" ? "" : "not ", "ok 3\n"; $/ = 77; print "ok 4\n"; $proca->transfer ($main); print $/ == 77 ? "" : "not ", "ok 6\n"; $proca->transfer ($main); print "not ok 7\n"; die; } sub b { print $/ ne "\n" ? "not " : "", "ok 8\n"; $procb->transfer ($main); print "not ok 9\n"; die; } $/ = 55; print "ok 2\n"; $main->transfer ($proca); print $/ != 55 ? "not " : "ok 5\n"; $main->transfer ($proca); print $/ != 55 ? "not " : "ok 7\n"; $main->transfer ($procb); print $/ != 55 ? "not " : "ok 9\n"; Coro-6.57/t/11_deadlock.t0000644000000000000000000000117512115435171013556 0ustar rootrootBEGIN { if ($^O =~ /mswin32/i) { print <(); }; schedule; exit 3; }; waitpid $pid, 0; print 3 == $? >> 8 ? "not " : "", "ok 3\n"; my $coro = new Coro sub { print "ok 5\n"; Coro::Util::_exit 0; }; $Coro::idle = sub { $coro->ready; }; print "ok 4\n"; schedule; die; Coro-6.57/t/04_rwlock.t0000644000000000000000000000205713514360412013312 0ustar rootroot$|=1; print "1..25\n"; use Coro; use Coro::RWLock; my $l = new Coro::RWLock; print "ok 1\n"; $l->rdlock; print (($l->tryrdlock ? "" : "not "), "ok 2\n"); print (($l->trywrlock ? "not " : ""), "ok 3\n"); $l->unlock; $l->unlock; print (($l->trywrlock ? "" : "not "), "ok 4\n"); print (($l->trywrlock ? "not " : ""), "ok 5\n"); print (($l->tryrdlock ? "not " : ""), "ok 6\n"); async { print "ok 8\n"; $l->wrlock; print "ok 10\n"; $l->unlock; $l->rdlock; print "ok 11\n"; cede; print "ok 14\n"; $l->unlock; }; print "ok 7\n"; cede; cede; cede; cede; print "ok 9\n"; $l->unlock; cede; print "ok 12\n"; $l->rdlock; print "ok 13\n"; cede; cede; print "ok 15\n"; $l->unlock; cede; print "ok 16\n"; $l->wrlock; print "ok 17\n"; Coro::async_pool { print "ok 18\n"; $l->rdlock; print "ok 21\n"; cede; print "ok 23\n"; $l->unlock; }; Coro::async_pool { print "ok 19\n"; $l->rdlock; print "ok 22\n"; cede; print "ok 24\n"; $l->unlock; }; cede; print "ok 20\n"; $l->unlock; cede; cede; print "ok 25\n"; Coro-6.57/t/08_join.t0000644000000000000000000000074411671415525012765 0ustar rootroot$|=1; print "1..10\n"; use Coro; print "ok 1\n"; $p1 = async { print "ok 3\n"; terminate 5; }; $p2 = async { print "ok 4\n"; () }; $p3 = async { print "ok 5\n"; (0,1,2) }; print "ok 2\n"; print 0 == @{[$p2->join]} ? "ok " : "not ok ", "6\n"; print 0 == ($p3->join)[0] ? "ok " : "not ok ", "7\n"; print 1 == ($p3->join)[1] ? "ok " : "not ok ", "8\n"; print 2 == ($p3->join)[2] ? "ok " : "not ok ", "9\n"; print 5 == $p1->join ? "ok " : "not ok ", "10\n"; Coro-6.57/t/17_rouse.t0000644000000000000000000000036411110715230013141 0ustar rootroot$|=1; print "1..5\n"; no warnings; use Coro; my $cb; async { $cb = Coro::rouse_cb; print "ok 2\n"; print Coro::rouse_wait == 77 ? "" : "not", "ok 4\n"; }; print "ok 1\n"; cede; print "ok 3\n"; $cb->(13, 77); cede; print "ok 5\n"; Coro-6.57/t/14_load.t0000644000000000000000000000067111020071374012725 0ustar rootrootBEGIN { $| = 1; print "1..17\n"; } my $idx; for my $module (qw( Coro::State Coro Coro::MakeMaker Coro::Signal Coro::Semaphore Coro::SemaphoreSet Coro::Channel Coro::Specific Coro::RWLock Coro::AnyEvent Coro::Timer Coro::Util Coro::Select Coro::Handle Coro::Socket Coro::Storable Coro::Debug )) { eval "use $module"; print $@ ? "not " : "", "ok ", ++$idx, " # $module ($@)\n"; } Coro-6.57/t/07_eval.t0000644000000000000000000000106110703050532012731 0ustar rootroot$|=1; print "1..5\n"; use Coro; async { my $t = eval "2"; print "ok $t\n"; cede; # a panic: restartop in this test can be caused by perl 5.8.8 not # properly handling constant folding (change 29976/28148) # (fixed in 5.10, 5.8.9) # we don't want to scare users, so disable it. delete $SIG{__DIE__} if $] < 5.008009; print defined eval "1/0" ? "not ok" : "ok", " 4\n"; }; async { my $t = eval "3"; print "ok $t\n"; cede; print defined eval "die" ? "not ok" : "ok", " 5\n"; }; print "ok 1\n"; cede; cede; cede; cede; Coro-6.57/t/15_semaphore.t0000644000000000000000000000313612305255214013775 0ustar rootroot$|=1; print "1..6\n"; use Coro; use Coro::Semaphore; { my $sem = new Coro::Semaphore 2; my $rand = 0; sub xrand { $rand = ($rand * 121 + 2121) % 212121; $rand / 212120 } my $counter; $_->join for map { async { my $current = $Coro::current; for (1..100) { cede if 0.2 > xrand; Coro::async_pool { $current->ready } if 0.2 > xrand; $counter += $sem->count; my $guard = $sem->guard; cede; cede; cede; cede; } } } 1..15 ; print $counter == 998 ? "" : "not ", "ok 1 # $counter\n"; } # check terminate { my $sem = new Coro::Semaphore 0; $as1 = async { my $g = $sem->guard; print "not ok 2\n"; }; $as2 = async { my $g = $sem->guard; print "ok 2\n"; }; cede; $sem->up; # wake up as1 $as1->cancel; # destroy as1 before it could ->guard $as1->join; $as2->join; } # check throw { my $sem = new Coro::Semaphore 0; $as1 = async { my $g = eval { $sem->guard; }; print $@ ? "" : "not ", "ok 3\n"; }; $as2 = async { my $g = $sem->guard; print "ok 4\n"; }; cede; $sem->up; # wake up as1 $as1->throw (1); # destroy as1 before it could ->guard $as1->join; $as2->join; } # check wait { my $sem = new Coro::Semaphore 0; $as1 = async { $sem->wait; print "ok 5\n"; }; $as2 = async { my $g = $sem->guard; print "ok 6\n"; }; cede; $sem->up; # wake up as1 $as1->join; $as2->join; } Coro-6.57/t/03_channel.t0000644000000000000000000000107310766043362013425 0ustar rootroot$|=1; print "1..10\n"; # adapted testcase by Richard Hundt use strict; use Coro; use Coro::Channel; my $c1 = new Coro::Channel 1; my $c2 = new Coro::Channel 1; async { print "ok 2\n"; print $c1->get eq "sig 1" ? "" : "not ", "ok 4\n"; $c2->put ('OK 1'); print "ok 7\n"; $c1->put ('last'); }; async { print "ok 3\n"; $c1->put('sig 1'); print "ok 5\n"; print $c2->get eq "OK 1" ? "" : "not ", "ok 6\n"; $Coro::main->ready; }; print "ok 1\n"; schedule; print "ok 8\n"; print $c1->get eq "last" ? "" : "not ", "ok 9\n"; print "ok 10\n"; Coro-6.57/t/10_bugs.t0000644000000000000000000000052710700304275012745 0ustar rootroot$|=1; print "1..3\n"; # test for known buggy perls use Coro; print "ok 1\n"; # Debian allocates 0.25mb of local variables in Perl_magic_get, # normal is <<256 bytes. If your perl segfaults here, try getting a # newer one or increase the C context stack space to a few megs. async { print "ok 2\n"; $1 }->join; print "ok 3\n"; Coro-6.57/t/02_channel.t0000644000000000000000000000045411002441402013403 0ustar rootroot$|=1; print "1..19\n"; use Coro; use Coro::Channel; my $q = new Coro::Channel 1; async { # producer for (1..9) { print "ok ", $_*2, "\n"; $q->put($_); } }; print "ok 1\n"; cede; for (11..19) { my $x = $q->get; print $x == $_-10 ? "ok " : "not ok ", ($_-10)*2+1, "\n"; } Coro-6.57/t/20_mutual_cancel.t0000644000000000000000000000145311556573660014641 0ustar rootroot$|=1; print "1..10\n"; # when two coros cancel each other mutually, # the slf function currently being executed needs to # be cleaned up, otherwise the next slf call in the cleanup code # will simply resume the previous call. # in addition, mutual cancellation must be specially handled # as currently, we sometimes cancel coros from another coro # which must not be interrupted (see slf_init_cancel). use Coro; print "ok 1\n"; my ($a, $b); sub xyz::DESTROY { print "ok 7\n"; $b->cancel; print "ok 8\n"; } $b = async { print "ok 3\n"; cede; print "ok 6\n"; $a->cancel; print "not ok 7\n"; }; $a = async { print "ok 4\n"; my $x = bless \my $dummy, "xyz"; cede; print "not ok 5\n"; }; print "ok 2\n"; cede; print "ok 5\n"; cede; print "ok 9\n"; cede; print "ok 10\n"; Coro-6.57/t/05_specific.t0000644000000000000000000000124307330153465013602 0ustar rootroot$|=1; print "1..8\n"; use Coro::Specific; # first test without coro print "ok 1\n"; my $s1 = new Coro::Specific; my $s2 = new Coro::Specific; $$s1 = 5; $$s2 = $$s1+5; print (($$s2 == 10 ? "" : "not "), "ok 2\n"); print (($$s1 == $$s2-5 ? "" : "not "), "ok 3\n"); # now let coro inherit the first task require Coro; Coro::async(sub { print ((!defined $$s2 ? "" : "not "), "ok 5\n"); $$s1 = 6; $$s2 = $$s1 + 6; $$s2++; Coro::cede(); print (($$s2 == 13 ? "" : "not "), "ok 7\n"); }); print (($$s2 == 10 ? "" : "not "), "ok 4\n"); &Coro::cede; print (($$s2 == 10 ? "" : "not "), "ok 6\n"); &Coro::cede; print (($$s2 == 10 ? "" : "not "), "ok 8\n"); Coro-6.57/t/12_exit.t0000644000000000000000000000067611016132556012767 0ustar rootrootBEGIN { if ($^O =~ /mswin32/i) { print <down; # wait for signal # ... some other "thread" $sig->up; =head1 DESCRIPTION This module implements counting semaphores. You can initialize a mutex with any level of parallel users, that is, you can initialize a sempahore that can be Ced more than once until it blocks. There is no owner associated with semaphores, so one thread can C it while another can C it (or vice versa), C can be called before C and so on: the semaphore is really just an integer counter that optionally blocks when it is 0. Counting semaphores are typically used to coordinate access to resources, with the semaphore count initialized to the number of free resources. Threads then increment the count when resources are added and decrement the count when resources are removed. You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::Semaphore; use common::sense; use Coro (); our $VERSION = 6.57; =item new [initial count] Creates a new sempahore object with the given initial lock count. The default lock count is 1, which means it is unlocked by default. Zero (or negative values) are also allowed, in which case the semaphore is locked by default. =item $sem->count Returns the current semaphore count. The semaphore can be down'ed without blocking when the count is strictly higher than C<0>. =item $sem->adjust ($diff) Atomically adds the amount given to the current semaphore count. If the count becomes positive, wakes up any waiters. Does not block if the count becomes negative, however. =item $sem->down Decrement the counter, therefore "locking" the semaphore. This method waits until the semaphore is available if the counter is zero or less. =item $sem->wait Similar to C, but does not actually decrement the counter. Instead, when this function returns, a following call to C or C is guaranteed to succeed without blocking, until the next thread switch (C etc.). Note that using C is much less efficient than using C, so try to prefer C whenever possible. =item $sem->wait ($callback) If you pass a callback argument to C, it will not wait, but immediately return. The callback will be called as soon as the semaphore becomes available (which might be instantly), and gets passed the semaphore as first argument. The callback might C the semaphore exactly once, might wake up other threads, but is I allowed to block (switch to other threads). =cut #=item $status = $sem->timed_down ($timeout) # #Like C, but returns false if semaphore couldn't be acquired within #$timeout seconds, otherwise true. #sub timed_down { # require Coro::Timer; # my $timeout = Coro::Timer::timeout ($_[1]); # # while ($_[0][0] <= 0) { # push @{$_[0][1]}, $Coro::current; # &Coro::schedule; # if ($timeout) { # # ugly as hell. slow, too, btw! # for (0..$#{$_[0][1]}) { # if ($_[0][1][$_] == $Coro::current) { # splice @{$_[0][1]}, $_, 1; # return; # } # } # die; # } # } # # --$_[0][0]; # return 1; #} =item $sem->up Unlock the semaphore again. =item $sem->try Try to C the semaphore. Returns true when this was possible, otherwise return false and leave the semaphore unchanged. =item $sem->waiters In scalar context, returns the number of threads waiting for this semaphore. Might accidentally cause WW3 if called in other contexts, so don't use these. =item $guard = $sem->guard This method calls C and then creates a guard object. When the guard object is destroyed it automatically calls C. =cut sub guard { &down; bless [$_[0]], Coro::Semaphore::guard:: } #=item $guard = $sem->timed_guard ($timeout) # #Like C, but returns undef if semaphore couldn't be acquired within #$timeout seconds, otherwise the guard object. #sub timed_guard { # &timed_down # ? bless \\$_[0], Coro::Semaphore::guard:: # : (); #} sub Coro::Semaphore::guard::DESTROY { &up($_[0][0]); } =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut 1 Coro-6.57/Coro/Signal.pm0000644000000000000000000000436613710272352013543 0ustar rootroot=head1 NAME Coro::Signal - thread signals (binary semaphores) =head1 SYNOPSIS use Coro; my $sig = new Coro::Signal; $sig->wait; # wait for signal # ... some other "thread" $sig->send; =head1 DESCRIPTION This module implements signals/binary semaphores/condition variables (basically all the same thing). You can wait for a signal to occur or send it, in which case it will wake up one waiter, or it can be broadcast, waking up all waiters. It is recommended not to mix C and C calls on the same C without some deep thinking: while it should work as documented, it can easily confuse you :-> You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::Signal; use common::sense; use Coro::Semaphore (); our $VERSION = 6.57; =item $sig = new Coro::Signal; Create a new signal. =item $sig->wait Wait for the signal to occur (via either C or C). Returns immediately if the signal has been sent before. =item $sig->wait ($callback) If you pass a callback argument to C, it will not wait, but immediately return. The callback will be called under the same conditions as C without arguments would continue the thrad. The callback might wake up any number of threads, but is I allowed to block (switch to other threads). =item $sig->send Send the signal, waking up I waiting process or remember the signal if no process is waiting. =item $sig->broadcast Send the signal, waking up I waiting process. If no process is waiting the signal is lost. =item $sig->awaited Return true when the signal is being awaited by some process. =cut #=item $status = $s->timed_wait ($timeout) # #Like C, but returns false if no signal happens within $timeout #seconds, otherwise true. # #See C for some reliability concerns. # #=cut #ub timed_wait { # require Coro::Timer; # my $timeout = Coro::Timer::timeout($_[1]); # # unless (delete $_[0][0]) { # push @{$_[0][1]}, $Coro::current; # &Coro::schedule; # # return 0 if $timeout; # } # # 1 # 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/AIO.pm0000644000000000000000000001151013710272352012723 0ustar rootroot=head1 NAME Coro::AIO - truly asynchronous file and directory I/O =head1 SYNOPSIS use Coro::AIO; # can now use any of the aio requests your IO::AIO module supports. # read 1MB of /etc/passwd, without blocking other coroutines my $fh = aio_open "/etc/passwd", O_RDONLY, 0 or die "/etc/passwd: $!"; aio_read $fh, 0, 1_000_000, my $buf, 0 or die "aio_read: $!"; aio_close $fh; =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module implements a thin wrapper around L. All of the functions that expect a callback are being wrapped by this module. The API is exactly the same as that of the corresponding IO::AIO routines, except that you have to specify I arguments, even the ones optional in IO::AIO, I the callback argument. Instead of calling a callback, the routines return the values normally passed to the callback. Everything else, including C<$!> and perls stat cache, are set as expected after these functions return. You can mix calls to C functions with calls to this module. You I, however, call these routines from within IO::AIO callbacks, as this causes a deadlock. Start a coro inside the callback instead. This module also loads L to integrate into the event loop in use, so please refer to its (and L's) documentation on how it selects an appropriate event module. All other functions exported by default by IO::AIO (e.g. C) will be exported by default by Coro::AIO, too. Functions that can be optionally imported from IO::AIO can be imported from Coro::AIO or can be called directly, e.g. C. You cannot specify priorities with C if your coroutine has a non-zero priority, as this module overwrites the request priority with the current coroutine priority in that case. For your convenience, here are the changed function signatures for most of the requests, for documentation of these functions please have a look at L. Note that requests added by newer versions of L will be automatically wrapped as well. =over 4 =cut package Coro::AIO; use common::sense; use IO::AIO 3.1 (); use AnyEvent::AIO (); use Coro (); use Coro::AnyEvent (); use base Exporter::; our $VERSION = 6.57; our @EXPORT = (@IO::AIO::EXPORT, qw(aio_wait)); our @EXPORT_OK = @IO::AIO::EXPORT_OK; our $AUTOLOAD; { my @reqs = @IO::AIO::AIO_REQ ? @IO::AIO::AIO_REQ : @IO::AIO::EXPORT; my %reqs = map +($_ => 1), @reqs; eval join "", map "sub $_(" . (prototype "IO::AIO::$_") . ");", grep !$reqs{$_}, @IO::AIO::EXPORT, @EXPORT_OK; for my $sub (@reqs) { push @EXPORT, $sub; my $iosub = "IO::AIO::$sub"; my $proto = prototype $iosub; $proto =~ s/;//g; # we do not support optional arguments $proto =~ s/^(\$*)\$$/$1/ or die "$iosub($proto): unable to remove callback slot from prototype"; # we add ; to avoid generating "$" which is specialcased to mean named unary function # without this, Coro::AIO::aio_mlockall IO::AIO::MCL_CURRENT | IO::AIO::MCL_FUTURE # is parsed as (Coro::AIO::aio_mlockall IO::AIO::MCL_CURRENT) | IO::AIO::MCL_FUTURE. $proto .= ";"; _register "Coro::AIO::$sub", $proto, \&{$iosub}; } _register "Coro::AIO::aio_wait", '$', \&IO::AIO::REQ::cb; } sub AUTOLOAD { (my $func = $AUTOLOAD) =~ s/^.*:://; *$AUTOLOAD = \&{"IO::AIO::$func"}; goto &$AUTOLOAD; } =item @results = aio_wait $req This is not originally an IO::AIO request: what it does is to wait for C<$req> to finish and return the results. This is most useful with C requests. Is currently implemented by replacing the C<$req> callback (and is very much like a wrapper around C<< $req->cb () >>). =item $fh = aio_open $pathname, $flags, $mode =item $status = aio_close $fh =item $retval = aio_read $fh,$offset,$length, $data,$dataoffset =item $retval = aio_write $fh,$offset,$length, $data,$dataoffset =item $retval = aio_sendfile $out_fh, $in_fh, $in_offset, $length =item $retval = aio_readahead $fh,$offset,$length =item $status = aio_stat $fh_or_path =item $status = aio_lstat $fh =item $status = aio_unlink $pathname =item $status = aio_rmdir $pathname =item $entries = aio_readdir $pathname =item ($dirs, $nondirs) = aio_scandir $path, $maxreq =item $status = aio_fsync $fh =item $status = aio_fdatasync $fh =item ... = aio_xxx ... Any additional aio requests follow the same scheme: same parameters except you must not specify a callback but instead get the callback arguments as return values. =back =head1 SEE ALSO L and L for non-blocking socket operation. =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut 1 Coro-6.57/Coro/state.h0000644000000000000000000000641013132250647013252 0ustar rootroot/* used in state.h */ #ifndef VAR #define VAR(name,type) VARx(name, PL_ ## name, type) #endif /* list the interpreter variables that need to be saved/restored */ VARx(defsv, GvSV (PL_defgv), SV *) VARx(defav, GvAV (PL_defgv), AV *) VARx(errsv, GvSV (PL_errgv), SV *) VARx(irsgv, GvSV (irsgv), SV *) VARx(hinthv, GvHV (PL_hintgv), HV *) /* mostly copied from thrdvar.h */ VAR(stack_sp, SV **) /* the main stack */ #ifdef OP_IN_REGISTER VAR(opsave, OP *) /* probably not necessary */ #else VAR(op, OP *) /* currently executing op */ #endif VAR(curpad, SV **) /* active pad (lexicals+tmps) */ VAR(stack_base, SV **) VAR(stack_max, SV **) VAR(scopestack, I32 *) /* scopes we've ENTERed */ VAR(scopestack_ix, I32) VAR(scopestack_max,I32) #if HAS_SCOPESTACK_NAME VAR(scopestack_name,const char **) #endif VAR(savestack, ANY *) /* items that need to be restored when LEAVEing scopes we've ENTERed */ VAR(savestack_ix, I32) VAR(savestack_max, I32) VAR(tmps_stack, SV **) /* mortals we've made */ VAR(tmps_ix, SSize_t) VAR(tmps_floor, SSize_t) VAR(tmps_max, SSize_t) VAR(markstack, I32 *) /* stack_sp locations we're remembering */ VAR(markstack_ptr, I32 *) VAR(markstack_max, I32 *) #if !PERL_VERSION_ATLEAST (5,9,0) VAR(retstack, OP **) /* OPs we have postponed executing */ VAR(retstack_ix, I32) VAR(retstack_max, I32) #endif VAR(curpm, PMOP *) /* what to do \ interps in REs from */ VAR(rs, SV *) /* input record separator $/ */ VAR(defoutgv, GV *) /* default FH for output */ VAR(curcop, COP *) VAR(curstack, AV *) /* THE STACK */ VAR(curstackinfo, PERL_SI *) /* current stack + context */ VAR(sortcop, OP *) /* user defined sort routine */ VAR(sortstash, HV *) /* which is in some package or other */ #if !PERL_VERSION_ATLEAST (5,9,0) VAR(sortcxix, I32) /* from pp_ctl.c */ #endif #if PERL_VERSION_ATLEAST (5,9,0) VAR(localizing, U8) /* are we processing a local() list? */ VAR(in_eval, U8) /* trap "fatal" errors? */ #else VAR(localizing, U32) /* are we processing a local() list? */ VAR(in_eval, U32) /* trap "fatal" errors? */ #endif VAR(tainted, bool) /* using variables controlled by $< */ VAR(diehook, SV *) VAR(warnhook, SV *) /* compcv is intrpvar, but seems to be thread-specific to me */ /* but, well, I thoroughly misunderstand what thrdvar and intrpvar is. still. */ VAR(compcv, CV *) /* currently compiling subroutine */ VAR(comppad, AV *) /* storage for lexically scoped temporaries */ VAR(comppad_name, PADNAMELIST *) /* variable names for "my" variables */ VAR(comppad_name_fill, PADOFFSET) /* last "introduced" variable offset */ VAR(comppad_name_floor, PADOFFSET) /* start of vars in innermost block */ VAR(runops, runops_proc_t) /* for tracing support */ VAR(hints, U32) /* pragma-tic compile-time flags */ #if PERL_VERSION_ATLEAST (5,10,0) VAR(parser, yy_parser *) #endif #undef VAR #undef VARx Coro-6.57/Coro/schmorp.h0000644000000000000000000002337211534213061013604 0ustar rootroot#ifndef SCHMORP_PERL_H_ #define SCHMORP_PERL_H_ /* WARNING * This header file is a shared resource between many modules. */ #include #include #if defined(_WIN32) || defined(_MINIX) # define SCHMORP_H_PREFER_SELECT 1 #endif #if !SCHMORP_H_PREFER_SELECT # include #endif /* useful stuff, used by schmorp mostly */ #include "patchlevel.h" #define PERL_VERSION_ATLEAST(a,b,c) \ (PERL_REVISION > (a) \ || (PERL_REVISION == (a) \ && (PERL_VERSION > (b) \ || (PERL_VERSION == (b) && PERL_SUBVERSION >= (c))))) #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif #if !PERL_VERSION_ATLEAST (5,6,0) # ifndef PL_ppaddr # define PL_ppaddr ppaddr # endif # ifndef call_sv # define call_sv perl_call_sv # endif # ifndef get_sv # define get_sv perl_get_sv # endif # ifndef get_cv # define get_cv perl_get_cv # endif # ifndef IS_PADGV # define IS_PADGV(v) 0 # endif # ifndef IS_PADCONST # define IS_PADCONST(v) 0 # endif #endif /* 5.11 */ #ifndef CxHASARGS # define CxHASARGS(cx) (cx)->blk_sub.hasargs #endif /* 5.10.0 */ #ifndef SvREFCNT_inc_NN # define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv) #endif /* 5.8.8 */ #ifndef GV_NOTQUAL # define GV_NOTQUAL 0 #endif #ifndef newSV # define newSV(l) NEWSV(0,l) #endif #ifndef CvISXSUB_on # define CvISXSUB_on(cv) (void)cv #endif #ifndef CvISXSUB # define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE) #endif #ifndef Newx # define Newx(ptr,nitems,type) New (0,ptr,nitems,type) #endif /* 5.8.7 */ #ifndef SvRV_set # define SvRV_set(s,v) SvRV(s) = (v) #endif static int s_signum (SV *sig) { #ifndef SIG_SIZE /* kudos to Slaven Rezic for the idea */ static char sig_size [] = { SIG_NUM }; # define SIG_SIZE (sizeof (sig_size) + 1) #endif dTHX; int signum; SvGETMAGIC (sig); for (signum = 1; signum < SIG_SIZE; ++signum) if (strEQ (SvPV_nolen (sig), PL_sig_name [signum])) return signum; signum = SvIV (sig); if (signum > 0 && signum < SIG_SIZE) return signum; return -1; } static int s_signum_croak (SV *sig) { int signum = s_signum (sig); if (signum < 0) { dTHX; croak ("%s: invalid signal name or number", SvPV_nolen (sig)); } return signum; } static int s_fileno (SV *fh, int wr) { dTHX; SvGETMAGIC (fh); if (SvROK (fh)) { fh = SvRV (fh); SvGETMAGIC (fh); } if (SvTYPE (fh) == SVt_PVGV) return PerlIO_fileno (wr ? IoOFP (sv_2io (fh)) : IoIFP (sv_2io (fh))); if (SvOK (fh) && (SvIV (fh) >= 0) && (SvIV (fh) < 0x7fffffffL)) return SvIV (fh); return -1; } static int s_fileno_croak (SV *fh, int wr) { int fd = s_fileno (fh, wr); if (fd < 0) { dTHX; croak ("%s: illegal fh argument, either not an OS file or read/write mode mismatch", SvPV_nolen (fh)); } return fd; } static SV * s_get_cv (SV *cb_sv) { dTHX; HV *st; GV *gvp; return (SV *)sv_2cv (cb_sv, &st, &gvp, 0); } static SV * s_get_cv_croak (SV *cb_sv) { SV *cv = s_get_cv (cb_sv); if (!cv) { dTHX; croak ("%s: callback must be a CODE reference or another callable object", SvPV_nolen (cb_sv)); } return cv; } /*****************************************************************************/ /* gensub: simple closure generation utility */ #define S_GENSUB_ARG CvXSUBANY (cv).any_ptr /* create a closure from XS, returns a code reference */ /* the arg can be accessed via GENSUB_ARG from the callback */ /* the callback must use dXSARGS/XSRETURN */ static SV * s_gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg) { CV *cv = (CV *)newSV (0); sv_upgrade ((SV *)cv, SVt_PVCV); CvANON_on (cv); CvISXSUB_on (cv); CvXSUB (cv) = xsub; S_GENSUB_ARG = arg; return newRV_noinc ((SV *)cv); } /*****************************************************************************/ /* portable pipe/socketpair */ #ifdef USE_SOCKETS_AS_HANDLES # define S_TO_HANDLE(x) ((HANDLE)win32_get_osfhandle (x)) #else # define S_TO_HANDLE(x) ((HANDLE)x) #endif #ifdef _WIN32 /* taken almost verbatim from libev's ev_win32.c */ /* oh, the humanity! */ static int s_pipe (int filedes [2]) { dTHX; struct sockaddr_in addr = { 0 }; int addr_size = sizeof (addr); struct sockaddr_in adr2; int adr2_size = sizeof (adr2); SOCKET listener; SOCKET sock [2] = { -1, -1 }; if ((listener = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET) return -1; addr.sin_family = AF_INET; addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK); addr.sin_port = 0; if (bind (listener, (struct sockaddr *)&addr, addr_size)) goto fail; if (getsockname (listener, (struct sockaddr *)&addr, &addr_size)) goto fail; if (listen (listener, 1)) goto fail; if ((sock [0] = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET) goto fail; if (connect (sock [0], (struct sockaddr *)&addr, addr_size)) goto fail; if ((sock [1] = accept (listener, 0, 0)) < 0) goto fail; /* windows vista returns fantasy port numbers for getpeername. * example for two interconnected tcp sockets: * * (Socket::unpack_sockaddr_in getsockname $sock0)[0] == 53364 * (Socket::unpack_sockaddr_in getpeername $sock0)[0] == 53363 * (Socket::unpack_sockaddr_in getsockname $sock1)[0] == 53363 * (Socket::unpack_sockaddr_in getpeername $sock1)[0] == 53365 * * wow! tridirectional sockets! * * this way of checking ports seems to work: */ if (getpeername (sock [0], (struct sockaddr *)&addr, &addr_size)) goto fail; if (getsockname (sock [1], (struct sockaddr *)&adr2, &adr2_size)) goto fail; errno = WSAEINVAL; if (addr_size != adr2_size || addr.sin_addr.s_addr != adr2.sin_addr.s_addr /* just to be sure, I mean, it's windows */ || addr.sin_port != adr2.sin_port) goto fail; closesocket (listener); #ifdef USE_SOCKETS_AS_HANDLES /* when select isn't winsocket, we also expect socket, connect, accept etc. * to work on fds */ filedes [0] = sock [0]; filedes [1] = sock [1]; #else filedes [0] = _open_osfhandle (sock [0], 0); filedes [1] = _open_osfhandle (sock [1], 0); #endif return 0; fail: closesocket (listener); if (sock [0] != INVALID_SOCKET) closesocket (sock [0]); if (sock [1] != INVALID_SOCKET) closesocket (sock [1]); return -1; } #define s_socketpair(domain,type,protocol,filedes) s_pipe (filedes) static int s_fd_blocking (int fd, int blocking) { u_long nonblocking = !blocking; return ioctlsocket ((SOCKET)S_TO_HANDLE (fd), FIONBIO, &nonblocking); } #define s_fd_prepare(fd) s_fd_blocking (fd, 0) #else #define s_socketpair(domain,type,protocol,filedes) socketpair (domain, type, protocol, filedes) #define s_pipe(filedes) pipe (filedes) static int s_fd_blocking (int fd, int blocking) { return fcntl (fd, F_SETFL, blocking ? 0 : O_NONBLOCK); } static int s_fd_prepare (int fd) { return s_fd_blocking (fd, 0) || fcntl (fd, F_SETFD, FD_CLOEXEC); } #endif #if __linux && (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 7)) # define SCHMORP_H_HAVE_EVENTFD 1 /* our minimum requirement is glibc 2.7 which has the stub, but not the header */ # include # ifdef __cplusplus extern "C" { # endif int eventfd (unsigned int initval, int flags); # ifdef __cplusplus } # endif #else # define eventfd(initval,flags) -1 #endif typedef struct { int fd[2]; /* read, write fd, might be equal */ int len; /* write length (1 pipe/socket, 8 eventfd) */ } s_epipe; static int s_epipe_new (s_epipe *epp) { s_epipe ep; ep.fd [0] = ep.fd [1] = eventfd (0, 0); if (ep.fd [0] >= 0) { s_fd_prepare (ep.fd [0]); ep.len = 8; } else { if (s_pipe (ep.fd)) return -1; if (s_fd_prepare (ep.fd [0]) || s_fd_prepare (ep.fd [1])) { dTHX; close (ep.fd [0]); close (ep.fd [1]); return -1; } ep.len = 1; } *epp = ep; return 0; } static void s_epipe_destroy (s_epipe *epp) { dTHX; close (epp->fd [0]); if (epp->fd [1] != epp->fd [0]) close (epp->fd [1]); epp->len = 0; } static void s_epipe_signal (s_epipe *epp) { #ifdef _WIN32 /* perl overrides send with a function that crashes in other threads. * unfortunately, it overrides it with an argument-less macro, so * there is no way to force usage of the real send function. * incompetent windows programmers - is this redundant? */ DWORD dummy; WriteFile (S_TO_HANDLE (epp->fd [1]), (LPCVOID)&dummy, 1, &dummy, 0); #else # if SCHMORP_H_HAVE_EVENTFD static uint64_t counter = 1; # else static char counter [8]; # endif /* some modules accept fd's from outside, support eventfd here */ if (write (epp->fd [1], &counter, epp->len) < 0 && errno == EINVAL && epp->len != 8) write (epp->fd [1], &counter, (epp->len = 8)); #endif } static void s_epipe_drain (s_epipe *epp) { dTHX; char buf [9]; #ifdef _WIN32 recv (epp->fd [0], buf, sizeof (buf), 0); #else read (epp->fd [0], buf, sizeof (buf)); #endif } /* like new, but dups over old */ static int s_epipe_renew (s_epipe *epp) { dTHX; s_epipe epn; if (epp->fd [1] != epp->fd [0]) close (epp->fd [1]); if (s_epipe_new (&epn)) return -1; if (epp->len) { if (dup2 (epn.fd [0], epp->fd [0]) < 0) croak ("unable to dup over old event pipe"); /* should not croak */ close (epn.fd [0]); if (epn.fd [0] == epn.fd [1]) epn.fd [1] = epp->fd [0]; epn.fd [0] = epp->fd [0]; } *epp = epn; return 0; } #define s_epipe_fd(epp) ((epp)->fd [0]) static int s_epipe_wait (s_epipe *epp) { dTHX; #if SCHMORP_H_PREFER_SELECT fd_set rfd; int fd = s_epipe_fd (epp); FD_ZERO (&rfd); FD_SET (fd, &rfd); return PerlSock_select (fd + 1, &rfd, 0, 0, 0); #else /* poll is preferable on posix systems */ struct pollfd pfd; pfd.fd = s_epipe_fd (epp); pfd.events = POLLIN; return poll (&pfd, 1, -1); #endif } #endif Coro-6.57/Coro/Socket.pm0000644000000000000000000001253713710272352013555 0ustar rootroot=head1 NAME Coro::Socket - non-blocking socket-I/O =head1 SYNOPSIS use Coro::Socket; # listen on an ipv4 socket my $socket = new Coro::Socket PeerHost => "localhost", PeerPort => 'finger'; # listen on any other type of socket my $socket = Coro::Socket->new_from_fh (IO::Socket::UNIX->new Local => "/tmp/socket", Type => SOCK_STREAM, ); =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module implements socket-handles in a coroutine-compatible way, that is, other coroutines can run while reads or writes block on the handle. See L, especially the note about prefering method calls. =head1 IPV6 WARNING This module was written to imitate the L API, and derive from it. Since IO::Socket::INET does not support IPv6, this module does neither. Therefore it is not recommended to use Coro::Socket in new code. Instead, use L and L, e.g.: use Coro; use Coro::Handle; use AnyEvent::Socket; # use tcp_connect from AnyEvent::Socket # and call Coro::Handle::unblock on it. tcp_connect "www.google.com", 80, Coro::rouse_cb; my $fh = unblock +(Coro::rouse_wait)[0]; # now we have a perfectly thread-safe socket handle in $fh print $fh "GET / HTTP/1.0\015\012\015\012"; local $/; print <$fh>; Using C gives you transparent IPv6, multi-homing, SRV-record etc. support. For listening sockets, use C. =over 4 =cut package Coro::Socket; use common::sense; use Errno (); use Carp qw(croak); use Socket; use IO::Socket::INET (); use Coro::Util (); use base qw(Coro::Handle IO::Socket::INET); our $VERSION = 6.57; our (%_proto, %_port); sub _proto($) { $_proto{$_[0]} ||= do { ((getprotobyname $_[0])[2] || (getprotobynumber $_[0])[2]) or croak "unsupported protocol: $_[0]"; }; } sub _port($$) { $_port{$_[0],$_[1]} ||= do { return $_[0] if $_[0] =~ /^\d+$/; $_[0] =~ /([^(]+)\s*(?:\((\d+)\))?/x or croak "unparsable port number: $_[0]"; ((getservbyname $1, $_[1])[2] || (getservbyport $1, $_[1])[2] || $2) or croak "unknown port: $_[0]"; }; } sub _sa($$$) { my ($host, $port, $proto) = @_; $port or $host =~ s/:([^:]+)$// and $port = $1; my $_proto = _proto($proto); my $_port = _port($port, $proto); my $_host = Coro::Util::inet_aton $host or croak "$host: unable to resolve"; pack_sockaddr_in $_port, $_host } =item $fh = new Coro::Socket param => value, ... Create a new non-blocking tcp handle and connect to the given host and port. The parameter names and values are mostly the same as for IO::Socket::INET (as ugly as I think they are). The parameters officially supported currently are: C, C, C, C, C, C, C, C, C. $fh = new Coro::Socket PeerHost => "localhost", PeerPort => 'finger'; =cut sub _prepare_socket { my ($self, $arg) = @_; $self } sub new { my ($class, %arg) = @_; $arg{Proto} ||= 'tcp'; $arg{LocalHost} ||= delete $arg{LocalAddr}; $arg{PeerHost} ||= delete $arg{PeerAddr}; defined ($arg{Type}) or $arg{Type} = $arg{Proto} eq "tcp" ? SOCK_STREAM : SOCK_DGRAM; socket my $fh, PF_INET, $arg{Type}, _proto ($arg{Proto}) or return; my $self = bless Coro::Handle->new_from_fh ( $fh, timeout => $arg{Timeout}, forward_class => $arg{forward_class}, partial => $arg{partial}, ), $class or return; $self->configure (\%arg) } sub configure { my ($self, $arg) = @_; if ($arg->{ReuseAddr}) { $self->setsockopt (SOL_SOCKET, SO_REUSEADDR, 1) or croak "setsockopt(SO_REUSEADDR): $!"; } if ($arg->{ReusePort}) { $self->setsockopt (SOL_SOCKET, SO_REUSEPORT, 1) or croak "setsockopt(SO_REUSEPORT): $!"; } if ($arg->{Broadcast}) { $self->setsockopt (SOL_SOCKET, SO_BROADCAST, 1) or croak "setsockopt(SO_BROADCAST): $!"; } if ($arg->{SO_RCVBUF}) { $self->setsockopt (SOL_SOCKET, SO_RCVBUF, $arg->{SO_RCVBUF}) or croak "setsockopt(SO_RCVBUF): $!"; } if ($arg->{SO_SNDBUF}) { $self->setsockopt (SOL_SOCKET, SO_SNDBUF, $arg->{SO_SNDBUF}) or croak "setsockopt(SO_SNDBUF): $!"; } if ($arg->{LocalPort} || $arg->{LocalHost}) { my @sa = _sa($arg->{LocalHost} || "0.0.0.0", $arg->{LocalPort} || 0, $arg->{Proto}); $self->bind ($sa[0]) or croak "bind($arg->{LocalHost}:$arg->{LocalPort}): $!"; } if ($arg->{PeerHost}) { my @sa = _sa ($arg->{PeerHost}, $arg->{PeerPort}, $arg->{Proto}); for (@sa) { $! = 0; if ($self->connect ($_)) { next unless writable $self; $! = unpack "i", $self->getsockopt (SOL_SOCKET, SO_ERROR); } $! or last; $!{ECONNREFUSED} or $!{ENETUNREACH} or $!{ETIMEDOUT} or $!{EHOSTUNREACH} or return; } } elsif (exists $arg->{Listen}) { $self->listen ($arg->{Listen}) or return; } $self } 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/jit-amd64-unix.pl0000755000000000000000000000532111607145573015007 0ustar rootroot#!/opt/bin/perl { package Coro::State; use common::sense; my @insn; $insn[0][1] = "\x0f\xb6"; # movzbl mem -> rax $insn[0][2] = "\x0f\xb7"; # movzwl mem -> rax $insn[0][4] = "\x8b"; # movl mem -> rax $insn[0][8] = "\x48\x8b"; # movq mem -> rax $insn[1][1] = "\x88"; # movb al -> mem $insn[1][2] = "\x66\x89"; # movw ax -> mem $insn[1][4] = "\x89"; # movl eax -> mem $insn[1][8] = "\x48\x89"; # movq rax -> mem my $modrm_disp8 = 0x40; my $modrm_disp32 = 0x80; my $modrm_rsi = 0x06; my $modrm_rdi = 0x07; my @vars; my $mov_ind = sub { my ($size, $mod_rm, $store, $offset) = @_; if ($offset < -128 || $offset > 127) { $mod_rm |= $modrm_disp32; $offset = pack "V", $offset; } elsif ($offset) { $mod_rm |= $modrm_disp8; $offset = pack "c", $offset; } else { $offset = ""; } $insn[$store][$size] . (chr $mod_rm) . $offset }; my $gencopy = sub { my ($save) = shift; my $curbase = undef; my $code; my $curslot = 0; for (@vars) { my ($addr, $asize, $slot, $ssize) = @$_; if (!defined $curbase || abs ($curbase - $addr) > 0x7ffffff) { $curbase = $addr + 128; $code .= "\x48\xbe" . pack "Q", $curbase; # mov imm64, %rsi } my $slotofs = $slot - $curslot; # the sort ensures that this condition and adjustment suffices if ($slotofs > 127) { my $adj = 256; $code .= "\x48\x81\xc7" . pack "i", $adj; # addq imm32, %rdi $curslot += $adj; $slotofs -= $adj; } if ($save) { $code .= $mov_ind->($asize, $modrm_rsi, 0, $addr - $curbase); $code .= $mov_ind->($ssize, $modrm_rdi, 1, $slotofs); } else { $code .= $mov_ind->($ssize, $modrm_rdi, 0, $slotofs); $code .= $mov_ind->($asize, $modrm_rsi, 1, $addr - $curbase); } } $code .= "\xc3"; # retq $code }; sub _jit { @vars = @_; # sort all variables into 256 byte blocks, biased by -128 # so gencopy can += 256 occasionally. within those blocks, # sort by address so we can play further tricks. @vars = sort { (($a->[2] + 128) & ~255) <=> (($b->[2] + 128) & ~255) or $a->[0] <=> $b->[0] } @vars; # we *could* combine adjacent vars, but this is not very common my $load = $gencopy->(0); my $save = $gencopy->(1); #open my $fh, ">dat"; syswrite $fh, $save; system "objdump -b binary -m i386 -M x86-64 -D dat";#d# #warn length $load;#d# #warn length $save;#d# ($load, $save) } } 1 Coro-6.57/Coro/Util.pm0000644000000000000000000001267713710272352013247 0ustar rootroot=head1 NAME Coro::Util - various utility functions. =head1 SYNOPSIS use Coro::Util; =head1 DESCRIPTION This module implements various utility functions, mostly replacing perl functions by non-blocking counterparts. Many of these functions exist for the sole purpose of emulating existing interfaces, no matter how bad or limited they are (e.g. no IPv6 support). This module is an AnyEvent user. Refer to the L documentation to see how to integrate it into your own programs. =over 4 =cut package Coro::Util; use common::sense; use Socket (); use AnyEvent (); use AnyEvent::Socket (); use Coro::State; use Coro::Handle; use Coro::Storable (); use Coro::AnyEvent (); use Coro::Semaphore; use base 'Exporter'; our @EXPORT = qw(gethostbyname gethostbyaddr); our @EXPORT_OK = qw(inet_aton fork_eval); our $VERSION = 6.57; our $MAXPARALLEL = 16; # max. number of parallel jobs my $jobs = new Coro::Semaphore $MAXPARALLEL; sub _do_asy(&;@) { my $sub = shift; $jobs->down; my $fh; my $pid = open $fh, "-|"; if (!defined $pid) { die "fork: $!"; } elsif (!$pid) { syswrite STDOUT, join "\0", map { unpack "H*", $_ } &$sub; Coro::Util::_exit 0; } my $buf; my $wakeup = Coro::rouse_cb; my $w; $w = AE::io $fh, 0, sub { sysread $fh, $buf, 16384, length $buf and return; undef $w; $wakeup->(); }; Coro::rouse_wait; $jobs->up; my @r = map { pack "H*", $_ } split /\0/, $buf; wantarray ? @r : $r[0]; } =item $ipn = Coro::Util::inet_aton $hostname || $ip Works almost exactly like its C counterpart, except that it does not block other coroutines. Does not handle multihomed hosts or IPv6 - consider using C with the L rouse functions instead. =cut sub inet_aton { AnyEvent::Socket::inet_aton $_[0], Coro::rouse_cb; (grep length == 4, Coro::rouse_wait)[0] } =item gethostbyname, gethostbyaddr Work similarly to their Perl counterparts, but do not block. Uses C internally. Does not handle multihomed hosts or IPv6 - consider using C or C with the L rouse functions instead. =cut sub gethostbyname($) { AnyEvent::Socket::inet_aton $_[0], Coro::rouse_cb; ($_[0], $_[0], &Socket::AF_INET, 4, map +(AnyEvent::Socket::format_address $_), grep length == 4, Coro::rouse_wait) } sub gethostbyaddr($$) { _do_asy { gethostbyaddr $_[0], $_[1] } @_ } =item @result = Coro::Util::fork_eval { ... }, @args Executes the given code block or code reference with the given arguments in a separate process, returning the results. The return values must be serialisable with Coro::Storable. It may, of course, block. Note that using event handling in the sub is not usually a good idea as you will inherit a mixed set of watchers from the parent. Exceptions will be correctly forwarded to the caller. This function is useful for pushing cpu-intensive computations into a different process, for example to take advantage of multiple CPU's. Its also useful if you want to simply run some blocking functions (such as C) and do not care about the overhead enough to code your own pid watcher etc. This function might keep a pool of processes in some future version, as fork can be rather slow in large processes. You should also look at C, which is newer and more compatible to totally broken Perl implementations such as the one from ActiveState. Example: execute some external program (convert image to rgba raw form) and add a long computation (extract the alpha channel) in a separate process, making sure that never more then $NUMCPUS processes are being run. my $cpulock = new Coro::Semaphore $NUMCPUS; sub do_it { my ($path) = @_; my $guard = $cpulock->guard; Coro::Util::fork_eval { open my $fh, "convert -depth 8 \Q$path\E rgba:" or die "$path: $!"; local $/; # make my eyes hurt pack "C*", unpack "(xxxC)*", <$fh> } } my $alphachannel = do_it "/tmp/img.png"; =cut sub fork_eval(&@) { my ($cb, @args) = @_; pipe my $fh1, my $fh2 or die "pipe: $!"; my $pid = fork; if ($pid) { undef $fh2; my $res = Coro::Storable::thaw +(Coro::Handle::unblock $fh1)->readline (undef); waitpid $pid, 0; # should not block, we expect the child to simply behave die $$res unless "ARRAY" eq ref $res; return wantarray ? @$res : $res->[-1]; } elsif (defined $pid) { delete $SIG{__WARN__}; delete $SIG{__DIE__}; # just in case, this hack effectively disables event processing # in the child. cleaner and slower would be to canceling all # event watchers, but we are event-model agnostic. undef $Coro::idle; $Coro::current->prio (Coro::PRIO_MAX); eval { undef $fh1; my @res = eval { $cb->(@args) }; open my $fh, ">", \my $buf or die "fork_eval: cannot open fh-to-buf in child: $!"; Storable::store_fd $@ ? \"$@" : \@res, $fh; close $fh; syswrite $fh2, $buf; close $fh2; }; warn $@ if $@; Coro::Util::_exit 0; } else { die "fork_eval: $!"; } } # make sure store_fd is preloaded eval { Storable::store_fd undef, undef }; 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/Channel.pm0000644000000000000000000000772513710272352013700 0ustar rootroot=head1 NAME Coro::Channel - message queues =head1 SYNOPSIS use Coro; $q1 = new Coro::Channel ; $q1->put ("xxx"); print $q1->get; die unless $q1->size; =head1 DESCRIPTION A Coro::Channel is the equivalent of a unix pipe (and similar to amiga message ports): you can put things into it on one end and read things out of it from the other end. If the capacity of the Channel is maxed out writers will block. Both ends of a Channel can be read/written from by as many coroutines as you want concurrently. You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::Channel; use common::sense; use Coro (); use Coro::Semaphore (); our $VERSION = 6.57; sub DATA (){ 0 } sub SGET (){ 1 } sub SPUT (){ 2 } =item $q = new Coro:Channel $maxsize Create a new channel with the given maximum size (practically unlimited if C is omitted or zero). Giving a size of one gives you a traditional channel, i.e. a queue that can store only a single element (which means there will be no buffering, and C will wait until there is a corresponding C call). To buffer one element you have to specify C<2>, and so on. =cut sub new { # we cheat and set infinity == 2*10**9 bless [ [], # initially empty (Coro::Semaphore::_alloc 0), # counts data (Coro::Semaphore::_alloc +($_[1] || 2_000_000_000) - 1), # counts remaining space ] } =item $q->put ($scalar) Put the given scalar into the queue. =cut sub put { push @{$_[0][DATA]}, $_[1]; Coro::Semaphore::up $_[0][SGET]; Coro::Semaphore::down $_[0][SPUT]; } =item $q->get Return the next element from the queue, waiting if necessary. =cut sub get { Coro::Semaphore::down $_[0][SGET]; Coro::Semaphore::up $_[0][SPUT]; shift @{$_[0][DATA]} } =item $q->shutdown Shuts down the Channel by pushing a virtual end marker onto it: This changes the behaviour of the Channel when it becomes or is empty to return C, almost as if infinitely many C elements had been put into the queue. Specifically, this function wakes up any pending C calls and lets them return C, the same on future C calls. C will return the real number of stored elements, though. Another way to describe the behaviour is that C calls will not block when the queue becomes empty but immediately return C. This means that calls to C will work normally and the data will be returned on subsequent C calls. This method is useful to signal the end of data to any consumers, quite similar to an end of stream on e.g. a tcp socket: You have one or more producers that C data into the Channel and one or more consumers who C them. When all producers have finished producing data, a call to C signals this fact to any consumers. A common implementation uses one or more threads that C from a channel until it returns C. To clean everything up, first C the channel, then C the threads. =cut sub shutdown { Coro::Semaphore::adjust $_[0][SGET], 1_000_000_000; } =item $q->size Return the number of elements waiting to be consumed. Please note that: if ($q->size) { my $data = $q->get; ... } is I a race condition but instead works just fine. Note that the number of elements that wait can be larger than C<$maxsize>, as it includes any coroutines waiting to put data into the channel (but not any shutdown condition). This means that the number returned is I the number of calls to C that will succeed instantly and return some data. Calling C has no effect on this number. =cut sub size { scalar @{$_[0][DATA]} } # this is not undocumented by accident - if it breaks, you # get to keep the pieces sub adjust { Coro::Semaphore::adjust $_[0][SPUT], $_[1]; } 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/SemaphoreSet.pm0000644000000000000000000001014513710272352014715 0ustar rootroot=head1 NAME Coro::SemaphoreSet - efficient set of counting semaphores =head1 SYNOPSIS use Coro; $sig = new Coro::SemaphoreSet [initial value]; $sig->down ("semaphoreid"); # wait for signal # ... some other "thread" $sig->up ("semaphoreid"); =head1 DESCRIPTION This module implements sets of counting semaphores (see L). It is nothing more than a hash with normal semaphores as members, but is more efficiently managed. This is useful if you want to allow parallel tasks to run in parallel but not on the same problem. Just use a SemaphoreSet and lock on the problem identifier. You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::SemaphoreSet; use common::sense; our $VERSION = 6.57; use Coro::Semaphore (); =item new [initial count] Creates a new semaphore set with the given initial lock count for each individual semaphore. See L. =cut sub new { bless [defined $_[1] ? $_[1] : 1], $_[0] } =item $semset->down ($id) Decrement the counter, therefore "locking" the named semaphore. This method waits until the semaphore is available if the counter is zero. =cut sub down { # Coro::Semaphore::down increases the refcount, which we check in _may_delete Coro::Semaphore::down ($_[0][1]{$_[1]} ||= Coro::Semaphore::_alloc $_[0][0]); } #ub timed_down { # require Coro::Timer; # my $timeout = Coro::Timer::timeout ($_[2]); # # while () { # my $sem = ($_[0][1]{$_[1]} ||= [$_[0][0]]); # # if ($sem->[0] > 0) { # --$sem->[0]; # return 1; # } # # if ($timeout) { # # ugly as hell. # for (0..$#{$sem->[1]}) { # if ($sem->[1][$_] == $Coro::current) { # splice @{$sem->[1]}, $_, 1; # return 0; # } # } # die; # } # # push @{$sem->[1]}, $Coro::current; # &Coro::schedule; # } # =item $semset->up ($id) Unlock the semaphore again. If the semaphore reaches the default count for this set and has no waiters, the space allocated for it will be freed. =cut sub up { my ($self, $id) = @_; my $sem = $self->[1]{$id} ||= Coro::Semaphore::_alloc $self->[0]; Coro::Semaphore::up $sem; delete $self->[1]{$id} if _may_delete $sem, $self->[0], 1; } =item $semset->try ($id) Try to C the semaphore. Returns true when this was possible, otherwise return false and leave the semaphore unchanged. =cut sub try { Coro::Semaphore::try ( $_[0][1]{$_[1]} ||= $_[0][0] > 0 ? Coro::Semaphore::_alloc $_[0][0] : return 0 ) } =item $semset->count ($id) Return the current semaphore count for the specified semaphore. =cut sub count { Coro::Semaphore::count ($_[0][1]{$_[1]} || return $_[0][0]); } =item $semset->waiters ($id) Returns the number (in scalar context) or list (in list context) of waiters waiting on the specified semaphore. =cut sub waiters { Coro::Semaphore::waiters ($_[0][1]{$_[1]} || return); } =item $semset->wait ($id) Same as Coro::Semaphore::wait on the specified semaphore. =cut sub wait { Coro::Semaphore::wait ($_[0][1]{$_[1]} || return); } =item $guard = $semset->guard ($id) This method calls C and then creates a guard object. When the guard object is destroyed it automatically calls C. =cut sub guard { &down; bless [@_], Coro::SemaphoreSet::guard:: } #ub timed_guard { # &timed_down # ? bless [$_[0], $_[1]], Coro::SemaphoreSet::guard:: # : (); # sub Coro::SemaphoreSet::guard::DESTROY { up @{$_[0]}; } =item $semaphore = $semset->sem ($id) This SemaphoreSet version is based on Coro::Semaphore's. This function creates (if necessary) the underlying Coro::Semaphore object and returns it. You may legally call any Coro::Semaphore method on it, but note that calling C<< $semset->up >> can invalidate the returned semaphore. =cut sub sem { bless +($_[0][1]{$_[1]} ||= Coro::Semaphore::_alloc $_[0][0]), Coro::Semaphore::; } 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/libcoro/0000755000000000000000000000000013710272364013413 5ustar rootrootCoro-6.57/Coro/libcoro/LICENSE0000644000000000000000000000261211226120215014404 0ustar rootrootCopyright (c) 2000-2009 Marc Alexander Lehmann Redistribution and use in source and binary forms, with or without modifica- tion, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MER- CHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPE- CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTH- ERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Alternatively, the following files carry an additional notice that explicitly allows relicensing under the GPLv2: coro.c, coro.h. Coro-6.57/Coro/libcoro/README0000644000000000000000000000042510211643537014271 0ustar rootrootConfiguration, documentation etc. is provided in the coro.h file. Please note that the file conftest.c in this distribution is under the GPL. It is not needed for proper operation of this library though, for that, coro.h and coro.c suffice. Marc Lehmann Coro-6.57/Coro/libcoro/coro.c0000644000000000000000000005236513334573504014536 0ustar rootroot/* * Copyright (c) 2001-2011 Marc Alexander Lehmann * * Redistribution and use in source and binary forms, with or without modifica- * tion, are permitted provided that the following conditions are met: * * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MER- * CHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO * EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPE- * CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTH- * ERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED * OF THE POSSIBILITY OF SUCH DAMAGE. * * Alternatively, the contents of this file may be used under the terms of * the GNU General Public License ("GPL") version 2 or any later version, * in which case the provisions of the GPL are applicable instead of * the above. If you wish to allow the use of your version of this file * only under the terms of the GPL and not to allow others to use your * version of this file under the BSD license, indicate your decision * by deleting the provisions above and replace them with the notice * and other provisions required by the GPL. If you do not delete the * provisions above, a recipient may use your version of this file under * either the BSD or the GPL. * * This library is modelled strictly after Ralf S. Engelschalls article at * http://www.gnu.org/software/pth/rse-pmt.ps. So most of the credit must * go to Ralf S. Engelschall . */ #include "coro.h" #include #include /*****************************************************************************/ /* ucontext/setjmp/asm backends */ /*****************************************************************************/ #if CORO_UCONTEXT || CORO_SJLJ || CORO_LOSER || CORO_LINUX || CORO_IRIX || CORO_ASM # if CORO_UCONTEXT # include # endif # if !defined(STACK_ADJUST_PTR) # if __sgi /* IRIX is decidedly NON-unix */ # define STACK_ADJUST_PTR(sp,ss) ((char *)(sp) + (ss) - 8) # define STACK_ADJUST_SIZE(sp,ss) ((ss) - 8) # elif (__i386__ && CORO_LINUX) || (_M_IX86 && CORO_LOSER) # define STACK_ADJUST_PTR(sp,ss) ((char *)(sp) + (ss)) # define STACK_ADJUST_SIZE(sp,ss) (ss) # elif (__amd64__ && CORO_LINUX) || ((_M_AMD64 || _M_IA64) && CORO_LOSER) # define STACK_ADJUST_PTR(sp,ss) ((char *)(sp) + (ss) - 8) # define STACK_ADJUST_SIZE(sp,ss) (ss) # else # define STACK_ADJUST_PTR(sp,ss) (sp) # define STACK_ADJUST_SIZE(sp,ss) (ss) # endif # endif # include # if CORO_SJLJ # include # include # include # endif static coro_func coro_init_func; static void *coro_init_arg; static coro_context *new_coro, *create_coro; static void coro_init (void) { volatile coro_func func = coro_init_func; volatile void *arg = coro_init_arg; coro_transfer (new_coro, create_coro); #if __GCC_HAVE_DWARF2_CFI_ASM && __amd64 /*asm (".cfi_startproc");*/ /*asm (".cfi_undefined rip");*/ #endif func ((void *)arg); #if __GCC_HAVE_DWARF2_CFI_ASM && __amd64 /*asm (".cfi_endproc");*/ #endif /* the new coro returned. bad. just abort() for now */ abort (); } # if CORO_SJLJ static volatile int trampoline_done; /* trampoline signal handler */ static void trampoline (int sig) { if (coro_setjmp (new_coro->env)) coro_init (); /* start it */ else trampoline_done = 1; } # endif # if CORO_ASM #if __arm__ && \ (defined __ARM_ARCH_7__ || defined __ARM_ARCH_7A__ \ || defined __ARM_ARCH_7R__ || defined __ARM_ARCH_7M__ \ || __ARM_ARCH == 7) #define CORO_ARM 1 #endif #if _WIN32 || __CYGWIN__ #define CORO_WIN_TIB 1 #endif asm ( "\t.text\n" #if _WIN32 || __CYGWIN__ "\t.globl _coro_transfer\n" "_coro_transfer:\n" #else "\t.globl coro_transfer\n" "coro_transfer:\n" #endif /* windows, of course, gives a shit on the amd64 ABI and uses different registers */ /* http://blogs.msdn.com/freik/archive/2005/03/17/398200.aspx */ #if __amd64 #if _WIN32 || __CYGWIN__ #define NUM_SAVED 29 "\tsubq $168, %rsp\t" /* one dummy qword to improve alignment */ "\tmovaps %xmm6, (%rsp)\n" "\tmovaps %xmm7, 16(%rsp)\n" "\tmovaps %xmm8, 32(%rsp)\n" "\tmovaps %xmm9, 48(%rsp)\n" "\tmovaps %xmm10, 64(%rsp)\n" "\tmovaps %xmm11, 80(%rsp)\n" "\tmovaps %xmm12, 96(%rsp)\n" "\tmovaps %xmm13, 112(%rsp)\n" "\tmovaps %xmm14, 128(%rsp)\n" "\tmovaps %xmm15, 144(%rsp)\n" "\tpushq %rsi\n" "\tpushq %rdi\n" "\tpushq %rbp\n" "\tpushq %rbx\n" "\tpushq %r12\n" "\tpushq %r13\n" "\tpushq %r14\n" "\tpushq %r15\n" #if CORO_WIN_TIB "\tpushq %fs:0x0\n" "\tpushq %fs:0x8\n" "\tpushq %fs:0xc\n" #endif "\tmovq %rsp, (%rcx)\n" "\tmovq (%rdx), %rsp\n" #if CORO_WIN_TIB "\tpopq %fs:0xc\n" "\tpopq %fs:0x8\n" "\tpopq %fs:0x0\n" #endif "\tpopq %r15\n" "\tpopq %r14\n" "\tpopq %r13\n" "\tpopq %r12\n" "\tpopq %rbx\n" "\tpopq %rbp\n" "\tpopq %rdi\n" "\tpopq %rsi\n" "\tmovaps (%rsp), %xmm6\n" "\tmovaps 16(%rsp), %xmm7\n" "\tmovaps 32(%rsp), %xmm8\n" "\tmovaps 48(%rsp), %xmm9\n" "\tmovaps 64(%rsp), %xmm10\n" "\tmovaps 80(%rsp), %xmm11\n" "\tmovaps 96(%rsp), %xmm12\n" "\tmovaps 112(%rsp), %xmm13\n" "\tmovaps 128(%rsp), %xmm14\n" "\tmovaps 144(%rsp), %xmm15\n" "\taddq $168, %rsp\n" #else #define NUM_SAVED 6 "\tpushq %rbp\n" "\tpushq %rbx\n" "\tpushq %r12\n" "\tpushq %r13\n" "\tpushq %r14\n" "\tpushq %r15\n" "\tmovq %rsp, (%rdi)\n" "\tmovq (%rsi), %rsp\n" "\tpopq %r15\n" "\tpopq %r14\n" "\tpopq %r13\n" "\tpopq %r12\n" "\tpopq %rbx\n" "\tpopq %rbp\n" #endif "\tpopq %rcx\n" "\tjmpq *%rcx\n" #elif __i386__ #define NUM_SAVED 4 "\tpushl %ebp\n" "\tpushl %ebx\n" "\tpushl %esi\n" "\tpushl %edi\n" #if CORO_WIN_TIB #undef NUM_SAVED #define NUM_SAVED 7 "\tpushl %fs:0\n" "\tpushl %fs:4\n" "\tpushl %fs:8\n" #endif "\tmovl %esp, (%eax)\n" "\tmovl (%edx), %esp\n" #if CORO_WIN_TIB "\tpopl %fs:8\n" "\tpopl %fs:4\n" "\tpopl %fs:0\n" #endif "\tpopl %edi\n" "\tpopl %esi\n" "\tpopl %ebx\n" "\tpopl %ebp\n" "\tpopl %ecx\n" "\tjmpl *%ecx\n" #elif CORO_ARM /* untested, what about thumb, neon, iwmmxt? */ #if __ARM_PCS_VFP "\tvpush {d8-d15}\n" #define NUM_SAVED (9 + 8 * 2) #else #define NUM_SAVED 9 #endif "\tpush {r4-r11,lr}\n" "\tstr sp, [r0]\n" "\tldr sp, [r1]\n" "\tpop {r4-r11,lr}\n" #if __ARM_PCS_VFP "\tvpop {d8-d15}\n" #endif "\tmov r15, lr\n" #elif __mips__ && 0 /* untested, 32 bit only */ #define NUM_SAVED (12 + 8 * 2) /* TODO: n64/o64, lw=>ld */ "\t.set nomips16\n" "\t.frame $sp,112,$31\n" #if __mips_soft_float "\taddiu $sp,$sp,-44\n" #else "\taddiu $sp,$sp,-112\n" "\ts.d $f30,88($sp)\n" "\ts.d $f28,80($sp)\n" "\ts.d $f26,72($sp)\n" "\ts.d $f24,64($sp)\n" "\ts.d $f22,56($sp)\n" "\ts.d $f20,48($sp)\n" #endif "\tsw $28,40($sp)\n" "\tsw $31,36($sp)\n" "\tsw $fp,32($sp)\n" "\tsw $23,28($sp)\n" "\tsw $22,24($sp)\n" "\tsw $21,20($sp)\n" "\tsw $20,16($sp)\n" "\tsw $19,12($sp)\n" "\tsw $18,8($sp)\n" "\tsw $17,4($sp)\n" "\tsw $16,0($sp)\n" "\tsw $sp,0($4)\n" "\tlw $sp,0($5)\n" #if !__mips_soft_float "\tl.d $f30,88($sp)\n" "\tl.d $f28,80($sp)\n" "\tl.d $f26,72($sp)\n" "\tl.d $f24,64($sp)\n" "\tl.d $f22,56($sp)\n" "\tl.d $f20,48($sp)\n" #endif "\tlw $28,40($sp)\n" "\tlw $31,36($sp)\n" "\tlw $fp,32($sp)\n" "\tlw $23,28($sp)\n" "\tlw $22,24($sp)\n" "\tlw $21,20($sp)\n" "\tlw $20,16($sp)\n" "\tlw $19,12($sp)\n" "\tlw $18,8($sp)\n" "\tlw $17,4($sp)\n" "\tlw $16,0($sp)\n" "\tj $31\n" #if __mips_soft_float "\taddiu $sp,$sp,44\n" #else "\taddiu $sp,$sp,112\n" #endif #else #error unsupported architecture #endif ); # endif void coro_create (coro_context *ctx, coro_func coro, void *arg, void *sptr, size_t ssize) { coro_context nctx; # if CORO_SJLJ stack_t ostk, nstk; struct sigaction osa, nsa; sigset_t nsig, osig; # endif if (!coro) return; coro_init_func = coro; coro_init_arg = arg; new_coro = ctx; create_coro = &nctx; # if CORO_SJLJ /* we use SIGUSR2. first block it, then fiddle with it. */ sigemptyset (&nsig); sigaddset (&nsig, SIGUSR2); sigprocmask (SIG_BLOCK, &nsig, &osig); nsa.sa_handler = trampoline; sigemptyset (&nsa.sa_mask); nsa.sa_flags = SA_ONSTACK; if (sigaction (SIGUSR2, &nsa, &osa)) { perror ("sigaction"); abort (); } /* set the new stack */ nstk.ss_sp = STACK_ADJUST_PTR (sptr, ssize); /* yes, some platforms (IRIX) get this wrong. */ nstk.ss_size = STACK_ADJUST_SIZE (sptr, ssize); nstk.ss_flags = 0; if (sigaltstack (&nstk, &ostk) < 0) { perror ("sigaltstack"); abort (); } trampoline_done = 0; kill (getpid (), SIGUSR2); sigfillset (&nsig); sigdelset (&nsig, SIGUSR2); while (!trampoline_done) sigsuspend (&nsig); sigaltstack (0, &nstk); nstk.ss_flags = SS_DISABLE; if (sigaltstack (&nstk, 0) < 0) perror ("sigaltstack"); sigaltstack (0, &nstk); if (~nstk.ss_flags & SS_DISABLE) abort (); if (~ostk.ss_flags & SS_DISABLE) sigaltstack (&ostk, 0); sigaction (SIGUSR2, &osa, 0); sigprocmask (SIG_SETMASK, &osig, 0); # elif CORO_LOSER coro_setjmp (ctx->env); #if __CYGWIN__ && __i386__ ctx->env[8] = (long) coro_init; ctx->env[7] = (long) ((char *)sptr + ssize) - sizeof (long); #elif __CYGWIN__ && __x86_64__ ctx->env[7] = (long) coro_init; ctx->env[6] = (long) ((char *)sptr + ssize) - sizeof (long); #elif defined __MINGW32__ ctx->env[5] = (long) coro_init; ctx->env[4] = (long) ((char *)sptr + ssize) - sizeof (long); #elif defined _M_IX86 ((_JUMP_BUFFER *)&ctx->env)->Eip = (long) coro_init; ((_JUMP_BUFFER *)&ctx->env)->Esp = (long) STACK_ADJUST_PTR (sptr, ssize) - sizeof (long); #elif defined _M_AMD64 ((_JUMP_BUFFER *)&ctx->env)->Rip = (__int64) coro_init; ((_JUMP_BUFFER *)&ctx->env)->Rsp = (__int64) STACK_ADJUST_PTR (sptr, ssize) - sizeof (__int64); #elif defined _M_IA64 ((_JUMP_BUFFER *)&ctx->env)->StIIP = (__int64) coro_init; ((_JUMP_BUFFER *)&ctx->env)->IntSp = (__int64) STACK_ADJUST_PTR (sptr, ssize) - sizeof (__int64); #else #error "microsoft libc or architecture not supported" #endif # elif CORO_LINUX coro_setjmp (ctx->env); #if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 0 && defined (JB_PC) && defined (JB_SP) ctx->env[0].__jmpbuf[JB_PC] = (long) coro_init; ctx->env[0].__jmpbuf[JB_SP] = (long) STACK_ADJUST_PTR (sptr, ssize) - sizeof (long); #elif __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 0 && defined (__mc68000__) ctx->env[0].__jmpbuf[0].__aregs[0] = (long int)coro_init; ctx->env[0].__jmpbuf[0].__sp = (int *) ((char *)sptr + ssize) - sizeof (long); #elif defined (__GNU_LIBRARY__) && defined (__i386__) ctx->env[0].__jmpbuf[0].__pc = (char *) coro_init; ctx->env[0].__jmpbuf[0].__sp = (void *) ((char *)sptr + ssize) - sizeof (long); #elif defined (__GNU_LIBRARY__) && defined (__x86_64__) ctx->env[0].__jmpbuf[JB_PC] = (long) coro_init; ctx->env[0].__jmpbuf[0].__sp = (void *) ((char *)sptr + ssize) - sizeof (long); #else #error "linux libc or architecture not supported" #endif # elif CORO_IRIX coro_setjmp (ctx->env, 0); ctx->env[JB_PC] = (__uint64_t)coro_init; ctx->env[JB_SP] = (__uint64_t)STACK_ADJUST_PTR (sptr, ssize) - sizeof (long); # elif CORO_ASM #if __i386__ || __x86_64__ ctx->sp = (void **)(ssize + (char *)sptr); *--ctx->sp = (void *)abort; /* needed for alignment only */ *--ctx->sp = (void *)coro_init; #if CORO_WIN_TIB *--ctx->sp = 0; /* ExceptionList */ *--ctx->sp = (char *)sptr + ssize; /* StackBase */ *--ctx->sp = sptr; /* StackLimit */ #endif #elif CORO_ARM /* return address stored in lr register, don't push anything */ #else #error unsupported architecture #endif ctx->sp -= NUM_SAVED; memset (ctx->sp, 0, sizeof (*ctx->sp) * NUM_SAVED); #if __i386__ || __x86_64__ /* done already */ #elif CORO_ARM ctx->sp[0] = coro; /* r4 */ ctx->sp[1] = arg; /* r5 */ ctx->sp[8] = (char *)coro_init; /* lr */ #else #error unsupported architecture #endif # elif CORO_UCONTEXT getcontext (&(ctx->uc)); ctx->uc.uc_link = 0; ctx->uc.uc_stack.ss_sp = sptr; ctx->uc.uc_stack.ss_size = (size_t)ssize; ctx->uc.uc_stack.ss_flags = 0; makecontext (&(ctx->uc), (void (*)())coro_init, 0); # endif coro_transfer (create_coro, new_coro); } /*****************************************************************************/ /* pthread backend */ /*****************************************************************************/ #elif CORO_PTHREAD /* this mutex will be locked by the running coroutine */ pthread_mutex_t coro_mutex = PTHREAD_MUTEX_INITIALIZER; struct coro_init_args { coro_func func; void *arg; coro_context *self, *main; }; static void * coro_init (void *args_) { struct coro_init_args *args = (struct coro_init_args *)args_; coro_func func = args->func; void *arg = args->arg; coro_transfer (args->self, args->main); func (arg); return 0; } void coro_transfer (coro_context *prev, coro_context *next) { pthread_mutex_lock (&coro_mutex); next->flags = 1; pthread_cond_signal (&next->cv); prev->flags = 0; while (!prev->flags) pthread_cond_wait (&prev->cv, &coro_mutex); if (prev->flags == 2) { pthread_mutex_unlock (&coro_mutex); pthread_cond_destroy (&prev->cv); pthread_detach (pthread_self ()); pthread_exit (0); } pthread_mutex_unlock (&coro_mutex); } void coro_create (coro_context *ctx, coro_func coro, void *arg, void *sptr, size_t ssize) { static coro_context nctx; static int once; if (!once) { once = 1; pthread_cond_init (&nctx.cv, 0); } pthread_cond_init (&ctx->cv, 0); if (coro) { pthread_attr_t attr; struct coro_init_args args; pthread_t id; args.func = coro; args.arg = arg; args.self = ctx; args.main = &nctx; pthread_attr_init (&attr); #if __UCLIBC__ /* exists, but is borked */ /*pthread_attr_setstacksize (&attr, (size_t)ssize);*/ #elif __CYGWIN__ /* POSIX, not here */ pthread_attr_setstacksize (&attr, (size_t)ssize); #else pthread_attr_setstack (&attr, sptr, (size_t)ssize); #endif pthread_attr_setscope (&attr, PTHREAD_SCOPE_PROCESS); pthread_create (&id, &attr, coro_init, &args); coro_transfer (args.main, args.self); } } void coro_destroy (coro_context *ctx) { pthread_mutex_lock (&coro_mutex); ctx->flags = 2; pthread_cond_signal (&ctx->cv); pthread_mutex_unlock (&coro_mutex); } /*****************************************************************************/ /* fiber backend */ /*****************************************************************************/ #elif CORO_FIBER #define WIN32_LEAN_AND_MEAN #if _WIN32_WINNT < 0x0400 #undef _WIN32_WINNT #define _WIN32_WINNT 0x0400 #endif #include VOID CALLBACK coro_init (PVOID arg) { coro_context *ctx = (coro_context *)arg; ctx->coro (ctx->arg); } void coro_transfer (coro_context *prev, coro_context *next) { if (!prev->fiber) { prev->fiber = GetCurrentFiber (); if (prev->fiber == 0 || prev->fiber == (void *)0x1e00) prev->fiber = ConvertThreadToFiber (0); } SwitchToFiber (next->fiber); } void coro_create (coro_context *ctx, coro_func coro, void *arg, void *sptr, size_t ssize) { ctx->fiber = 0; ctx->coro = coro; ctx->arg = arg; if (!coro) return; ctx->fiber = CreateFiber (ssize, coro_init, ctx); } void coro_destroy (coro_context *ctx) { DeleteFiber (ctx->fiber); } #else #error unsupported backend #endif /*****************************************************************************/ /* stack management */ /*****************************************************************************/ #if CORO_STACKALLOC #include #ifndef _WIN32 # include #endif #if CORO_USE_VALGRIND # include #endif #if _POSIX_MAPPED_FILES # include # define CORO_MMAP 1 # ifndef MAP_ANONYMOUS # ifdef MAP_ANON # define MAP_ANONYMOUS MAP_ANON # else # undef CORO_MMAP # endif # endif # include #else # undef CORO_MMAP #endif #if _POSIX_MEMORY_PROTECTION # ifndef CORO_GUARDPAGES # define CORO_GUARDPAGES 4 # endif #else # undef CORO_GUARDPAGES #endif #if !CORO_MMAP # undef CORO_GUARDPAGES #endif #if !__i386__ && !__x86_64__ && !__powerpc__ && !__arm__ && !__aarch64__ && !__m68k__ && !__alpha__ && !__mips__ && !__sparc64__ # undef CORO_GUARDPAGES #endif #ifndef CORO_GUARDPAGES # define CORO_GUARDPAGES 0 #endif #if !PAGESIZE #if !CORO_MMAP #define PAGESIZE 4096 #else static size_t coro_pagesize (void) { static size_t pagesize; if (!pagesize) pagesize = sysconf (_SC_PAGESIZE); return pagesize; } #define PAGESIZE coro_pagesize () #endif #endif int coro_stack_alloc (struct coro_stack *stack, unsigned int size) { if (!size) size = 256 * 1024; stack->sptr = 0; stack->ssze = ((size_t)size * sizeof (void *) + PAGESIZE - 1) / PAGESIZE * PAGESIZE; #if CORO_FIBER stack->sptr = (void *)stack; return 1; #else size_t ssze = stack->ssze + CORO_GUARDPAGES * PAGESIZE; void *base; #if CORO_MMAP /* mmap supposedly does allocate-on-write for us */ base = mmap (0, ssze, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); if (base == (void *)-1) { /* some systems don't let us have executable heap */ /* we assume they won't need executable stack in that case */ base = mmap (0, ssze, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); if (base == (void *)-1) return 0; } #if CORO_GUARDPAGES mprotect (base, CORO_GUARDPAGES * PAGESIZE, PROT_NONE); #endif base = (void*)((char *)base + CORO_GUARDPAGES * PAGESIZE); #else base = malloc (ssze); if (!base) return 0; #endif #if CORO_USE_VALGRIND stack->valgrind_id = VALGRIND_STACK_REGISTER ((char *)base, ((char *)base) + ssze - CORO_GUARDPAGES * PAGESIZE); #endif stack->sptr = base; return 1; #endif } void coro_stack_free (struct coro_stack *stack) { #if CORO_FIBER /* nop */ #else #if CORO_USE_VALGRIND VALGRIND_STACK_DEREGISTER (stack->valgrind_id); #endif #if CORO_MMAP if (stack->sptr) munmap ((void*)((char *)stack->sptr - CORO_GUARDPAGES * PAGESIZE), stack->ssze + CORO_GUARDPAGES * PAGESIZE); #else free (stack->sptr); #endif #endif } #endif Coro-6.57/Coro/libcoro/coro.h0000644000000000000000000003670313334573374014546 0ustar rootroot/* * Copyright (c) 2001-2012,2015 Marc Alexander Lehmann * * Redistribution and use in source and binary forms, with or without modifica- * tion, are permitted provided that the following conditions are met: * * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MER- * CHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO * EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPE- * CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTH- * ERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED * OF THE POSSIBILITY OF SUCH DAMAGE. * * Alternatively, the contents of this file may be used under the terms of * the GNU General Public License ("GPL") version 2 or any later version, * in which case the provisions of the GPL are applicable instead of * the above. If you wish to allow the use of your version of this file * only under the terms of the GPL and not to allow others to use your * version of this file under the BSD license, indicate your decision * by deleting the provisions above and replace them with the notice * and other provisions required by the GPL. If you do not delete the * provisions above, a recipient may use your version of this file under * either the BSD or the GPL. * * This library is modelled strictly after Ralf S. Engelschalls article at * http://www.gnu.org/software/pth/rse-pmt.ps. So most of the credit must * go to Ralf S. Engelschall . * * This coroutine library is very much stripped down. You should either * build your own process abstraction using it or - better - just use GNU * Portable Threads, http://www.gnu.org/software/pth/. * */ /* * 2006-10-26 Include stddef.h on OS X to work around one of its bugs. * Reported by Michael_G_Schwern. * 2006-11-26 Use _setjmp instead of setjmp on GNU/Linux. * 2007-04-27 Set unwind frame info if gcc 3+ and ELF is detected. * Use _setjmp instead of setjmp on _XOPEN_SOURCE >= 600. * 2007-05-02 Add assembly versions for x86 and amd64 (to avoid reliance * on SIGUSR2 and sigaltstack in Crossfire). * 2008-01-21 Disable CFI usage on anything but GNU/Linux. * 2008-03-02 Switched to 2-clause BSD license with GPL exception. * 2008-04-04 New (but highly unrecommended) pthreads backend. * 2008-04-24 Reinstate CORO_LOSER (had wrong stack adjustments). * 2008-10-30 Support assembly method on x86 with and without frame pointer. * 2008-11-03 Use a global asm statement for CORO_ASM, idea by pippijn. * 2008-11-05 Hopefully fix misaligned stacks with CORO_ASM/SETJMP. * 2008-11-07 rbp wasn't saved in CORO_ASM on x86_64. * introduce coro_destroy, which is a nop except for pthreads. * speed up CORO_PTHREAD. Do no longer leak threads either. * coro_create now allows one to create source coro_contexts. * do not rely on makecontext passing a void * correctly. * try harder to get _setjmp/_longjmp. * major code cleanup/restructuring. * 2008-11-10 the .cfi hacks are no longer needed. * 2008-11-16 work around a freebsd pthread bug. * 2008-11-19 define coro_*jmp symbols for easier porting. * 2009-06-23 tentative win32-backend support for mingw32 (Yasuhiro Matsumoto). * 2010-12-03 tentative support for uclibc (which lacks all sorts of things). * 2011-05-30 set initial callee-saved-registers to zero with CORO_ASM. * use .cfi_undefined rip on linux-amd64 for better backtraces. * 2011-06-08 maybe properly implement weird windows amd64 calling conventions. * 2011-07-03 rely on __GCC_HAVE_DWARF2_CFI_ASM for cfi detection. * 2011-08-08 cygwin trashes stacks, use pthreads with double stack on cygwin. * 2012-12-04 reduce misprediction penalty for x86/amd64 assembly switcher. * 2012-12-05 experimental fiber backend (allocates stack twice). * 2012-12-07 API version 3 - add coro_stack_alloc/coro_stack_free. * 2012-12-21 valgrind stack registering was broken. * 2015-12-05 experimental asm be for arm7, based on a patch by Nick Zavaritsky. * use __name__ for predefined symbols, as in libecb. * enable guard pages on arm, aarch64 and mips. * 2016-08-27 try to disable _FORTIFY_SOURCE with CORO_SJLJ, as it * breaks setjmp/longjmp. Also disable CORO_ASM for asm by default, * as it was reported to crash. * 2016-11-18 disable cfi_undefined again - backtraces might be worse, but * compile compatibility is improved. * 2018-08-14 use a completely different pthread strategy that should allow * sharing of coroutines among different threads. this would * undefined behaviour before as mutexes would be unlocked on * a different thread. overall, this might be slower than * using a pipe for synchronisation, but pipes eat fd's... */ #ifndef CORO_H #define CORO_H #if __cplusplus extern "C" { #endif /* * This library consists of only three files * coro.h, coro.c and LICENSE (and optionally README) * * It implements what is known as coroutines, in a hopefully * portable way. * * All compiletime symbols must be defined both when including coro.h * (using libcoro) as well as when compiling coro.c (the implementation). * * You can manually specify which flavour you want. If you don't define * any of these, libcoro tries to choose a safe and fast default: * * -DCORO_UCONTEXT * * This flavour uses SUSv2's get/set/swap/makecontext functions that * unfortunately only some unices support, and is quite slow. * * -DCORO_SJLJ * * This flavour uses SUSv2's setjmp/longjmp and sigaltstack functions to * do it's job. Coroutine creation is much slower than UCONTEXT, but * context switching is a bit cheaper. It should work on almost all unices. * * -DCORO_LINUX * * CORO_SJLJ variant. * Old GNU/Linux systems (<= glibc-2.1) only work with this implementation * (it is very fast and therefore recommended over other methods, but * doesn't work with anything newer). * * -DCORO_LOSER * * CORO_SJLJ variant. * Microsoft's highly proprietary platform doesn't support sigaltstack, and * this selects a suitable workaround for this platform. It might not work * with your compiler though - it has only been tested with MSVC 6. * * -DCORO_FIBER * * Slower, but probably more portable variant for the Microsoft operating * system, using fibers. Ignores the passed stack and allocates it internally. * Also, due to bugs in cygwin, this does not work with cygwin. * * -DCORO_IRIX * * CORO_SJLJ variant. * For SGI's version of Microsoft's NT ;) * * -DCORO_ASM * * Hand coded assembly, known to work only on a few architectures/ABI: * GCC + arm7/x86/IA32/amd64/x86_64 + GNU/Linux and a few BSDs. Fastest * choice, if it works. * * -DCORO_PTHREAD * * Use the pthread API. You have to provide and -lpthread. * This is likely the slowest backend, and it also does not support fork(), * so avoid it at all costs. * * If you define neither of these symbols, coro.h will try to autodetect * the best/safest model. To help with the autodetection, you should check * (e.g. using autoconf) and define the following symbols: HAVE_UCONTEXT_H * / HAVE_SETJMP_H / HAVE_SIGALTSTACK. */ /* * Changes when the API changes incompatibly. * This is ONLY the API version - there is no ABI compatibility between releases. * * Changes in API version 2: * replaced bogus -DCORO_LOOSE with grammatically more correct -DCORO_LOSER * Changes in API version 3: * introduced stack management (CORO_STACKALLOC) */ #define CORO_VERSION 3 #include /* * This is the type for the initialization function of a new coroutine. */ typedef void (*coro_func)(void *); /* * A coroutine state is saved in the following structure. Treat it as an * opaque type. errno and sigmask might be saved, but don't rely on it, * implement your own switching primitive if you need that. */ typedef struct coro_context coro_context; /* * This function creates a new coroutine. Apart from a pointer to an * uninitialised coro_context, it expects a pointer to the entry function * and the single pointer value that is given to it as argument. * * Allocating/deallocating the stack is your own responsibility. * * As a special case, if coro, arg, sptr and ssze are all zero, * then an "empty" coro_context will be created that is suitable * as an initial source for coro_transfer. * * This function is not reentrant, but putting a mutex around it * will work. */ void coro_create (coro_context *ctx, /* an uninitialised coro_context */ coro_func coro, /* the coroutine code to be executed */ void *arg, /* a single pointer passed to the coro */ void *sptr, /* start of stack area */ size_t ssze); /* size of stack area in bytes */ /* * The following prototype defines the coroutine switching function. It is * sometimes implemented as a macro, so watch out. * * This function is thread-safe and reentrant. */ #if 0 void coro_transfer (coro_context *prev, coro_context *next); #endif /* * The following prototype defines the coroutine destroy function. It * is sometimes implemented as a macro, so watch out. It also serves no * purpose unless you want to use the CORO_PTHREAD backend, where it is * used to clean up the thread. You are responsible for freeing the stack * and the context itself. * * This function is thread-safe and reentrant. */ #if 0 void coro_destroy (coro_context *ctx); #endif /*****************************************************************************/ /* optional stack management */ /*****************************************************************************/ /* * You can disable all of the stack management functions by * defining CORO_STACKALLOC to 0. Otherwise, they are enabled by default. * * If stack management is enabled, you can influence the implementation via these * symbols: * * -DCORO_USE_VALGRIND * * If defined, then libcoro will include valgrind/valgrind.h and register * and unregister stacks with valgrind. * * -DCORO_GUARDPAGES=n * * libcoro will try to use the specified number of guard pages to protect against * stack overflow. If n is 0, then the feature will be disabled. If it isn't * defined, then libcoro will choose a suitable default. If guardpages are not * supported on the platform, then the feature will be silently disabled. */ #ifndef CORO_STACKALLOC # define CORO_STACKALLOC 1 #endif #if CORO_STACKALLOC /* * The only allowed operations on these struct members is to read the * "sptr" and "ssze" members to pass it to coro_create, to read the "sptr" * member to see if it is false, in which case the stack isn't allocated, * and to set the "sptr" member to 0, to indicate to coro_stack_free to * not actually do anything. */ struct coro_stack { void *sptr; size_t ssze; #if CORO_USE_VALGRIND int valgrind_id; #endif }; /* * Try to allocate a stack of at least the given size and return true if * successful, or false otherwise. * * The size is *NOT* specified in bytes, but in units of sizeof (void *), * i.e. the stack is typically 4(8) times larger on 32 bit(64 bit) platforms * then the size passed in. * * If size is 0, then a "suitable" stack size is chosen (usually 1-2MB). */ int coro_stack_alloc (struct coro_stack *stack, unsigned int size); /* * Free the stack allocated by coro_stack_alloc again. It is safe to * call this function on the coro_stack structure even if coro_stack_alloc * failed. */ void coro_stack_free (struct coro_stack *stack); #endif /* * That was it. No other user-serviceable parts below here. */ /*****************************************************************************/ #if !defined CORO_LOSER && !defined CORO_UCONTEXT \ && !defined CORO_SJLJ && !defined CORO_LINUX \ && !defined CORO_IRIX && !defined CORO_ASM \ && !defined CORO_PTHREAD && !defined CORO_FIBER # if defined WINDOWS && (defined __i386__ || (__x86_64__ || defined _M_IX86 || defined _M_AMD64) # define CORO_ASM 1 # elif defined WINDOWS || defined _WIN32 # define CORO_LOSER 1 /* you don't win with windoze */ # elif __linux && (__i386__ || (__x86_64__ && !__ILP32__) /*|| (__arm__ && __ARM_ARCH == 7)), not working */ # define CORO_ASM 1 # elif defined HAVE_UCONTEXT_H # define CORO_UCONTEXT 1 # elif defined HAVE_SETJMP_H && defined HAVE_SIGALTSTACK # define CORO_SJLJ 1 # else error unknown or unsupported architecture # endif #endif /*****************************************************************************/ #if CORO_UCONTEXT # include struct coro_context { ucontext_t uc; }; # define coro_transfer(p,n) swapcontext (&((p)->uc), &((n)->uc)) # define coro_destroy(ctx) (void *)(ctx) #elif CORO_SJLJ || CORO_LOSER || CORO_LINUX || CORO_IRIX # if defined(CORO_LINUX) && !defined(_GNU_SOURCE) # define _GNU_SOURCE /* for glibc */ # endif /* try to disable well-meant but buggy checks in some libcs */ # ifdef _FORTIFY_SOURCE # undef _FORTIFY_SOURCE # undef __USE_FORTIFY_LEVEL /* helps some more when too much has been included already */ # endif # if !CORO_LOSER # include # endif /* solaris is hopelessly borked, it expands _XOPEN_UNIX to nothing */ # if __sun # undef _XOPEN_UNIX # define _XOPEN_UNIX 1 # endif # include # if _XOPEN_UNIX > 0 || defined (_setjmp) # define coro_jmp_buf jmp_buf # define coro_setjmp(env) _setjmp (env) # define coro_longjmp(env) _longjmp ((env), 1) # elif CORO_LOSER # define coro_jmp_buf jmp_buf # define coro_setjmp(env) setjmp (env) # define coro_longjmp(env) longjmp ((env), 1) # else # define coro_jmp_buf sigjmp_buf # define coro_setjmp(env) sigsetjmp (env, 0) # define coro_longjmp(env) siglongjmp ((env), 1) # endif struct coro_context { coro_jmp_buf env; }; # define coro_transfer(p,n) do { if (!coro_setjmp ((p)->env)) coro_longjmp ((n)->env); } while (0) # define coro_destroy(ctx) (void *)(ctx) #elif CORO_ASM struct coro_context { void **sp; /* must be at offset 0 */ }; #if __i386__ || __x86_64__ void __attribute__ ((__noinline__, __regparm__(2))) #else void __attribute__ ((__noinline__)) #endif coro_transfer (coro_context *prev, coro_context *next); # define coro_destroy(ctx) (void *)(ctx) #elif CORO_PTHREAD # include extern pthread_mutex_t coro_mutex; struct coro_context { int flags; pthread_cond_t cv; }; void coro_transfer (coro_context *prev, coro_context *next); void coro_destroy (coro_context *ctx); #elif CORO_FIBER struct coro_context { void *fiber; /* only used for initialisation */ coro_func coro; void *arg; }; void coro_transfer (coro_context *prev, coro_context *next); void coro_destroy (coro_context *ctx); #endif #if __cplusplus } #endif #endif Coro-6.57/Coro/libcoro/conftest.c0000644000000000000000000001067510211643537015412 0ustar rootroot/* * This file was taken from pth-1.40/aclocal.m4 * The original copyright is below. * * GNU Pth - The GNU Portable Threads * Copyright (c) 1999-2001 Ralf S. Engelschall * * This file is part of GNU Pth, a non-preemptive thread scheduling * library which can be found at http://www.gnu.org/software/pth/. * * This file is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This file is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this file; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 * USA, or contact Marc Lehmann . */ #include #include #include #if defined(TEST_sigstack) || defined(TEST_sigaltstack) #include #include #include #endif #if defined(TEST_makecontext) #include #endif union alltypes { long l; double d; void *vp; void (*fp)(void); char *cp; }; static volatile char *handler_addr = (char *)0xDEAD; #if defined(TEST_sigstack) || defined(TEST_sigaltstack) static volatile int handler_done = 0; void handler(int sig) { char garbage[1024]; int i; auto int dummy; for (i = 0; i < 1024; i++) garbage[i] = 'X'; handler_addr = (char *)&dummy; handler_done = 1; return; } #endif #if defined(TEST_makecontext) static ucontext_t uc_handler; static ucontext_t uc_main; void handler(void) { char garbage[1024]; int i; auto int dummy; for (i = 0; i < 1024; i++) garbage[i] = 'X'; handler_addr = (char *)&dummy; swapcontext(&uc_handler, &uc_main); return; } #endif int main(int argc, char *argv[]) { FILE *f; char *skaddr; char *skbuf; int sksize; char result[1024]; int i; sksize = 32768; skbuf = (char *)malloc(sksize*2+2*sizeof(union alltypes)); if (skbuf == NULL) exit(1); for (i = 0; i < sksize*2+2*sizeof(union alltypes); i++) skbuf[i] = 'A'; skaddr = skbuf+sizeof(union alltypes); #if defined(TEST_sigstack) || defined(TEST_sigaltstack) { struct sigaction sa; #if defined(TEST_sigstack) struct sigstack ss; #elif defined(TEST_sigaltstack) && defined(HAVE_STACK_T) stack_t ss; #else struct sigaltstack ss; #endif #if defined(TEST_sigstack) ss.ss_sp = (void *)(skaddr + sksize); ss.ss_onstack = 0; if (sigstack(&ss, NULL) < 0) exit(1); #elif defined(TEST_sigaltstack) ss.ss_sp = (void *)(skaddr + sksize); ss.ss_size = sksize; ss.ss_flags = 0; if (sigaltstack(&ss, NULL) < 0) exit(1); #endif memset((void *)&sa, 0, sizeof(struct sigaction)); sa.sa_handler = handler; sa.sa_flags = SA_ONSTACK; sigemptyset(&sa.sa_mask); sigaction(SIGUSR1, &sa, NULL); kill(getpid(), SIGUSR1); while (!handler_done) /*nop*/; } #endif #if defined(TEST_makecontext) { if (getcontext(&uc_handler) != 0) exit(1); uc_handler.uc_link = NULL; uc_handler.uc_stack.ss_sp = (void *)(skaddr + sksize); uc_handler.uc_stack.ss_size = sksize; uc_handler.uc_stack.ss_flags = 0; makecontext(&uc_handler, handler, 1); swapcontext(&uc_main, &uc_handler); } #endif if (handler_addr == (char *)0xDEAD) exit(1); if (handler_addr < skaddr+sksize) { /* stack was placed into lower area */ if (*(skaddr+sksize) != 'A') sprintf(result, "(skaddr)+(sksize)-%d,(sksize)-%d", sizeof(union alltypes), sizeof(union alltypes)); else strcpy(result, "(skaddr)+(sksize),(sksize)"); } else { /* stack was placed into higher area */ if (*(skaddr+sksize*2) != 'A') sprintf(result, "(skaddr),(sksize)-%d", sizeof(union alltypes)); else strcpy(result, "(skaddr),(sksize)"); } printf("%s\n", result); exit(0); } Coro-6.57/Coro/MakeMaker.pm0000644000000000000000000000724613710272352014163 0ustar rootrootpackage Coro::MakeMaker; use common::sense; use Config; use base 'Exporter'; our $installsitearch; our $VERSION = 6.57; our @EXPORT_OK = qw(&coro_args $installsitearch); my %opt; for my $opt (split /:+/, $ENV{PERL_MM_OPT}) { my ($k,$v) = split /=/, $opt; $opt{$k} = $v; } my $extra = $Config{sitearch}; $extra =~ s/$Config{prefix}/$opt{PREFIX}/ if exists $opt{PREFIX}; for my $d ($extra, @INC) { if (-e "$d/Coro/CoroAPI.h") { $installsitearch = $d; last; } } sub coro_args { my %arg = @_; $arg{INC} .= " -I$installsitearch/Coro"; %arg; } 1; __END__ =head1 NAME Coro::MakeMaker - MakeMaker glue for the XS-level Coro API =head1 SYNOPSIS This allows you to control coroutines from C/XS. =head1 DESCRIPTION For optimal performance, hook into Coro at the C-level. You'll need to make changes to your C and add code to your C / C file(s). =head1 WARNING When you hook in at the C-level you can get a I performance gain, but you also reduce the chances that your code will work unmodified with newer versions of C or C. This may or may not be a problem. Just be aware, and set your expectations accordingly. =head1 HOW TO =head2 Makefile.PL use Coro::MakeMaker qw(coro_args); # ... set up %args ... WriteMakefile (coro_args (%args)); =head2 XS #include "CoroAPI.h" BOOT: I_CORO_API ("YourModule"); =head2 API This is just a small overview - read the Coro/CoroAPI.h header file in the distribution, and check the examples in F and F, or as a more real-world example, the Deliantra game server (which uses Coro::MakeMaker). You can also drop me a mail if you run into any trouble. #define CORO_TRANSFER(prev,next) /* transfer from prev to next */ #define CORO_SCHEDULE /* like Coro::schedule */ #define CORO_CEDE /* like Coro::cede */ #define CORO_CEDE_NOTSELF /* like Coro::cede_notself */ #define CORO_READY(coro) /* like $coro->ready */ #define CORO_IS_READY(coro) /* like $coro->is_ready */ #define CORO_NREADY /* # of procs in ready queue */ #define CORO_CURRENT /* returns $Coro::current */ #define CORO_THROW /* exception pending? */ #define CORO_READYHOOK /* hook for event libs, see Coro::EV */ /* C-level coroutine struct, opaque, not used much */ struct coro; /* used for schedule-like-function prepares */ struct coro_transfer_args { struct coro *prev, *next; }; /* this is the per-perl-coro slf frame info */ struct CoroSLF { void (*prepare) (pTHX_ struct coro_transfer_args *ta); /* 0 means not yet initialised */ int (*check) (pTHX_ struct CoroSLF *frame); void *data; /* for use by prepare/check/destroy */ void (*destroy) (pTHX_ struct CoroSLF *frame); }; /* needs to fill in the *frame */ typedef void (*coro_slf_cb) (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items); #define CORO_SV_STATE(coro) /* returns the internal struct coro * */ #define CORO_EXECUTE_SLF(cv,init,ax) /* execute a schedule-like function */ #define CORO_EXECUTE_SLF_XS(init) /* SLF in XS, see e.g. Coro::EV */ /* called on enter/leave */ typedef void (*coro_enterleave_hook) (pTHX_ void *arg); #define CORO_ENTERLEAVE_HOOK(coro,enter,enter_arg,leave,leave_arg) /* install an XS-level enter/leave hook */ #define CORO_ENTERLEAVE_UNHOOK(coro,enter,leave) /* remove an XS-level enter/leave hook */ #define CORO_ENTERLEAVE_SCOPE_HOOK(enter,enter_arg,leave,leave_arg) /* install an XS-level enter/leave hook for the corrent scope */ =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/jit-x86-unix.pl0000755000000000000000000000564111575346170014526 0ustar rootroot#!/opt/bin/perl { package Coro::State; use common::sense; my @insn; $insn[0][1] = "\x0f\xb6"; # movzbl mem -> rax $insn[0][2] = "\x0f\xb7"; # movzwl mem -> rax $insn[0][4] = "\x8b"; # movl mem -> rax $insn[1][1] = "\x88"; # movb al -> mem $insn[1][2] = "\x66\x89"; # movw eax -> mem $insn[1][4] = "\x89"; # movl rax -> mem my $modrm_abs = 0x05; my $modrm_disp8 = 0x40; my $modrm_disp32 = 0x80; my $modrm_edx = 0x02; my @vars; my $mov = sub { my ($size, $mod_rm, $store, $offset) = @_; if ($mod_rm == $modrm_abs) { $offset = pack "V", $offset; } else { if ($offset < -128 || $offset > 127) { $mod_rm |= $modrm_disp32; $offset = pack "V", $offset; } elsif ($offset) { $mod_rm |= $modrm_disp8; $offset = pack "c", $offset; } else { $offset = ""; } } my $insn = $insn[$store][$size] . (chr $mod_rm) . $offset; # some instructions have shorter sequences $insn =~ s/^\x8b\x05/\xa1/; $insn =~ s/^\x88\x05/\xa2/; $insn =~ s/^\x66\x89\x05/\x66\xa3/; $insn =~ s/^\x89\x05/\xa3/; $insn }; my $gencopy = sub { my ($save) = shift; my $code = "\x8b\x54\x24\x04"; # mov 4(%esp),%edx my $curslot = 0; for (@vars) { my ($addr, $asize, $slot, $ssize) = @$_; my $slotofs = $slot - $curslot; # the sort ensures that this condition and adjustment suffices if ($slotofs > 127) { my $adj = 256; $code .= "\x81\xc2" . pack "V", $adj; # add imm32, %edi $curslot += $adj; $slotofs -= $adj; } if ($save) { $code .= $mov->($asize, $modrm_abs, 0, $addr); $code .= $mov->($ssize, $modrm_edx, 1, $slotofs); } else { $code .= $mov->($ssize, $modrm_edx, 0, $slotofs); $code .= $mov->($asize, $modrm_abs, 1, $addr); } } $code .= "\xc3"; # retl $code }; sub _jit { @vars = @_; # split 8-byte accesses into two 4-byte accesses # not needed even for 64 bit perls, but you never know for (@vars) { if ($_->[1] == 8) { die "Coro: FATAL - cannot handle size mismatch between 8 and $_->[3] byte slots.\n"; $_->[1] = $_->[3] = 4; push @vars, [$_->[0] + 4, 4, $_->[1] + 4, 4]; } } # sort by slot offset, required by gencopy to work @vars = sort { $a->[2] <=> $b->[2] } @vars; # we *could* combine adjacent vars, but this is not very common my $load = $gencopy->(0); my $save = $gencopy->(1); #open my $fh, ">dat"; syswrite $fh, $save; system "objdump -b binary -m i386 -D dat"; #warn length $load; #warn length $save; ($load, $save) } } 1 Coro-6.57/Coro/Specific.pm0000644000000000000000000000344413710272352014047 0ustar rootroot=head1 NAME Coro::Specific - manage coroutine-specific variables. =head1 SYNOPSIS use Coro::Specific; my $ref = new Coro::Specific; $$ref = 5; print $$ref; =head1 DESCRIPTION This module can be used to create variables (or better: references to them) that are specific to the currently executing coroutine. This module does not automatically load the Coro module (so the overhead will be small when no coroutines are used). A much faster method is to store extra keys into C<%$Coro::current> - all you have to do is to make sure that the key is unique (e.g. by prefixing it with your module name). You can even store data there before loading the L module - when Coro is loaded, the keys stored in C<%$Coro::current> are automatically attached to the coro thread executing the main program. You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::Specific; use common::sense; our $VERSION = 6.57; =item new Create a new coroutine-specific scalar and return a reference to it. The scalar is guaranteed to be "undef". Once such a scalar has been allocated you cannot deallocate it (yet), so allocate only when you must. =cut my $idx; sub new { my $var; tie $var, Coro::Specific::; \$var; } sub TIESCALAR { my $idx = $idx++; bless \$idx, $_[0]; } sub FETCH { $Coro::current->{_specific}[${$_[0]}]; } sub STORE { $Coro::current->{_specific}[${$_[0]}] = $_[1]; } #sub DESTROY { # push @idx, $$_[0]; #} 1; =back =head1 BUGS The actual coroutine specific values do not automatically get destroyed when the Coro::Specific object gets destroyed. =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/BDB.pm0000644000000000000000000000275413710272352012714 0ustar rootroot=head1 NAME Coro::BDB - truly asynchronous bdb access =head1 SYNOPSIS use Coro::BDB; use BDB; # can now use any of the bdb requests =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module implements a thin wrapper around the L module: Each BDB request that could block and doesn't get passed a callback will normally block all coroutines. after loading this module, this will no longer be the case (it provides a suitable sync prepare callback). It will also register an AnyEvent watcher as soon as AnyEvent chooses an event loop. The AnyEvent watcher can be disabled by executing C. Please notify the author of when and why you think this was necessary. This module does not export anything (unlike L), as BDB already supports leaving out the callback. (Unfortunately, it ties a C context to each coroutine executing such a callback, so in the future, it might export more efficient wrappers). =over 4 =cut package Coro::BDB; use common::sense; use BDB (); use AnyEvent::BDB (); use Coro (); use Coro::AnyEvent (); use base Exporter::; our $VERSION = 6.57; our $WATCHER; BDB::set_sync_prepare { my $cb = Coro::rouse_cb; ( sub { $cb->($!) }, sub { $! = Coro::rouse_wait }, ) }; =back =head1 SEE ALSO L of course. =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut 1 Coro-6.57/Coro/RWLock.pm0000644000000000000000000000440713710272352013463 0ustar rootroot=head1 NAME Coro::RWLock - reader/write locks =head1 SYNOPSIS use Coro; $lck = new Coro::RWLock; $lck->rdlock; # acquire read lock $lck->unlock; # unlock lock again # or: $lck->wrlock; # acquire write lock $lck->unlock; # unlock lock again # try a readlock if ($lck->tryrdlock) { ...; $l->unlock; } # try a write lock if ($lck->trywrlock) { ...; $l->unlock; } =head1 DESCRIPTION This module implements reader/write locks. A read can be acquired for read by many coroutines in parallel as long as no writer has locked it (shared access). A single write lock can be acquired when no readers exist. RWLocks basically allow many concurrent readers (without writers) OR a single writer (but no readers). You don't have to load C manually, it will be loaded automatically when you C and call the C constructor. =over 4 =cut package Coro::RWLock; use common::sense; use Coro (); our $VERSION = 6.57; =item $l = new Coro::RWLock; Create a new reader/writer lock. =cut sub new { # [wrcount, [wrqueue], rdcount, [rdqueue]] bless [0, [], 0, []], $_[0]; } =item $l->rdlock Acquire a read lock. =item $l->tryrdlock Try to acquire a read lock. =cut sub rdlock { while ($_[0][0]) { push @{$_[0][3]}, $Coro::current; &Coro::schedule; } ++$_[0][2]; } sub tryrdlock { return if $_[0][0]; ++$_[0][2]; } =item $l->wrlock Acquire a write lock. =item $l->trywrlock Try to acquire a write lock. =cut sub wrlock { while ($_[0][0] || $_[0][2]) { push @{$_[0][1]}, $Coro::current; &Coro::schedule; } ++$_[0][0]; } sub trywrlock { return if $_[0][0] || $_[0][2]; ++$_[0][0]; } =item $l->unlock Give up a previous C or C. =cut my $waiter; sub unlock { # either we are a reader or a writer. decrement accordingly. if ($_[0][2]) { return if --$_[0][2]; } else { $_[0][0]--; } # now we have the choice between waking up a writer or all readers. we choose the writer. if (@{$_[0][1]}) { (shift @{$_[0][1]})->ready; } else { $waiter->ready while $waiter = shift @{$_[0][3]}; } } 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/Select.pm0000644000000000000000000000730613710272352013542 0ustar rootroot=head1 NAME Coro::Select - a (slow but coro-aware) replacement for CORE::select =head1 SYNOPSIS use Coro::Select; # replace select globally (be careful, see below) use Core::Select 'select'; # only in this module use Coro::Select (); # use Coro::Select::select =head1 DESCRIPTION This module tries to create a fully working replacement for perl's C, so it should generally be the first module C'd in the main program. Note that overriding C themselves, and asking AnyEvent to use Coro::Select, which in turn asks AnyEvent will not quite work. You can also invoke it from the commandline as C. To override select only for a single module (e.g. C), use a code fragment like this to load it: { package Net::DBus::Reactor; use Coro::Select qw(select); use Net::DBus::Reactor; } Some modules (notably L) directly call C. For these modules, we need to patch the opcode table by sandwiching it between calls to C and C: BEGIN { use Coro::Select (); Coro::Select::patch_pp_sselect; require evil_poe_module_using_CORE::SELECT; Coro::Select::unpatch_pp_sselect; } =over 4 =cut package Coro::Select; use common::sense; use Errno; use Coro (); use Coro::State (); use AnyEvent 4.800001 (); use Coro::AnyEvent (); use base Exporter::; our $VERSION = 6.57; our @EXPORT_OK = "select"; sub import { my $pkg = shift; if (@_) { $pkg->export (scalar caller 0, @_); } else { $pkg->export ("CORE::GLOBAL", "select"); } } sub select(;*$$$) { if (@_ == 0) { return CORE::select } elsif (@_ == 1) { return CORE::select $_[0] } elsif (defined $_[3] && !$_[3]) { return CORE::select $_[0], $_[1], $_[2], $_[3] } else { my $nfound = 0; my @w; my $wakeup = Coro::rouse_cb; # AnyEvent does not do 'e', so replace it by 'r' for ([0, 0], [1, 1], [2, 0]) { my ($i, $poll) = @$_; if (defined $_[$i]) { my $rvec = \$_[$i]; # we parse the bitmask by first expanding it into # a string of bits for (unpack "b*", $$rvec) { # and then repeatedly matching a regex against it while (/1/g) { my $fd = (pos) - 1; push @w, AE::io $fd, $poll, sub { (vec $$rvec, $fd, 1) = 1; ++$nfound; $wakeup->(); }; } } $$rvec ^= $$rvec; # clear all bits } } push @w, AE::timer $_[3], 0, $wakeup if defined $_[3]; Coro::rouse_wait; return $nfound } } 1; =back =head1 BUGS For performance reasons, Coro::Select's select function might not properly detect bad file descriptors (but relying on EBADF is inherently non-portable). =head1 SEE ALSO L. =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/Makefile.PL0000644000000000000000000003742413512023372013737 0ustar rootrootuse strict; use ExtUtils::MakeMaker; use Config; $|=1; my $DEFINE; my @LIBS = []; my $threads = $Config{usethreads}; sub have_inc($) { scalar grep -r "$_/$_[0]", $Config{usrinc}, split / /, $Config{incpth} } use Config; print <= 4.4 ? "s" : "p"); } else { # seems newer openbsd platforms have marginally working pthreads, but # their pthreads break sigaltstack - reading the sigaltstack sources # again shows how fundamentally clueless those people are (if no thread # has ever been created, then the program is bound to a kernel-scheduled # entity. get that? GET THAT?) $iface = "p"; } } elsif ($^O =~ /solaris/) { # setjmp, ucontext seem to work, as well as asm $iface = $iface_asm || "s"; } elsif ($^O =~ /darwin/) { # assembler doesn't support .type # ucontext is of course totally broken (it just crashes) # surprisingly, pthreads seem to work $iface = "s"; } elsif ($^O =~ /dragonfly/) { # ucontext is totally broken on dragonfly bsd: # Fatal error 'siglongjmp()ing between thread contexts is undefined by POSIX 1003.1 $iface = "s"; } elsif (have_inc "ucontext.h") { # shame on this heuristic $iface = "u"; } else { $iface = "s"; } print <= 2.5) stop working with this implementation however. i IRIX. For some reason, SGI really does not like to follow POSIX (does that surprise you?), so this workaround might be needed (it's fast), although [s] and [u] should also work now. w Microsoft Windows. Try this on Microsoft Windows when using Cygwin or the MSVC compilers (e.g. ActiveState Perl, but see "a" for Strawberry Perl), although, as there is no standard on how to do this under windows, different environments might work differently. Doh. f Microsoft Windows. Try this on Microsoft Windows if w fails. It is slower and uses a lot more memory, but should be working all the time. p Use pthread API. Try to avoid this option, it was only created to make a point about the programming language shootout. It is unlikely to work with perls that have windows process emulation enabled ("perl threads"). It is also likely the slowest method of implementing coroutines. It might work fine as a last resort, however, as the pthread API is slightly better tested than ucontext functions for example. Of course, not on BSDs, who usually have very broken pthread implementations. Coro tries hard to come up with a suitable default for most systems, so pressing return at the prompt usually does the right thing. If you experience problems (e.g. make test fails) then you should experiment with this setting. EOF retry: my $r = prompt "Use which implementation,\n" . "etjmp, ctx, sm, rix, inux,

threads, indows, iber?", $iface; $iface = lc $1 if $r =~ /(\S)/; if ($iface eq "u") { $DEFINE .= " -DCORO_UCONTEXT"; print "\nUsing ucontext implementation\n\n"; conftest ("TEST_makecontext"); } elsif ($iface eq "s") { $DEFINE .= " -D_FORTIFY_SOURCE=0"; $DEFINE .= " -DCORO_SJLJ"; print "\nUsing setjmp/longjmp/sigaltstack implementation\n\n"; conftest ("TEST_sigaltstack"); } elsif ($iface eq "l") { $DEFINE .= " -DCORO_LINUX"; print "\nUsing linux-specific implementation\n\n"; } elsif ($iface eq "i") { $DEFINE .= " -DCORO_IRIX"; print "\nUsing irix-specific implementation\n\n"; } elsif ($iface eq "w") { $DEFINE .= " -DCORO_LOSER"; print "\nUsing windows-specific implementation\n\n"; } elsif ($iface eq "f") { $DEFINE .= " -DCORO_FIBER"; print "\nUsing windows-specific fiber implementation\n\n"; } elsif ($iface eq "a") { $DEFINE .= " -DCORO_ASM"; print "\nUsing handcoded assembler implementation\n\n"; } elsif ($iface eq "p") { $DEFINE .= " -DCORO_PTHREAD"; @LIBS = ["-lpthread"]; print "\nUsing pthread implementation\n\n"; } else { print "\nUnknown implementation \"$iface\"\n"; goto retry; } print < header file available. Valgrind support is completely optional, so disabling it is the safe choice. EOF my $valgrind = have_inc "valgrind/valgrind.h" ? "y" : "n"; $valgrind = $ENV{CORO_USE_VALGRIND} if exists $ENV{CORO_USE_VALGRIND}; $valgrind = prompt ("Enable valgrind support (y/n)?", $valgrind); $DEFINE .= " -DCORO_USE_VALGRIND=1" if $valgrind =~ /[yY]/; print <clone method (y/n)?", $masturbate); $DEFINE .= " -DCORO_CLONE=1" if $masturbate =~ /[yY]/; print < "Coro::State", VERSION_FROM => "State.pm", DEFINE => $DEFINE, LIBS => @LIBS, DIR => [], depend => { "State.c" => "state.h clone.c ecb.h libcoro/coro.h libcoro/coro.c", }, ); sub conftest { my $type = shift; print "\nTrying to detect stack growth direction (for $type)\n"; print "You might see some warnings, this should not concern you.\n\n"; system "$Config{cc} $Config{ccflags} -D$type libcoro/conftest.c"; my $res = qx<./a.out>; $res =~ s/\s+$//; my ($sp, $ss) = split /,/, $res; print "\n\n*****************************************************************************\n"; print "If the testsuite fails PLEASE provide the following information\n"; print "to Marc Lehmann : operating system name, version,\n"; print "architecture name and this string '$sp|$ss'. Thanks a lot!\n";#d# print "*****************************************************************************\n\n"; unlink "a.out"; unlink "conftestval"; } Coro-6.57/Coro/clone.c0000644000000000000000000003641011222613465013227 0ustar rootroot/* clone implementation, big, slow, useless, but not pointless */ static AV * clone_av (pTHX_ AV *av) { int i; AV *nav = newAV (); av_fill (nav, AvFILLp (av)); for (i = 0; i <= AvFILLp (av); ++i) AvARRAY (nav)[i] = SvREFCNT_inc (AvARRAY (av)[i]); return nav; } static struct coro * coro_clone (pTHX_ struct coro *coro) { perl_slots *slot, *nslot; struct coro *ncoro; if (coro->flags & (CF_RUNNING | CF_NEW)) croak ("Coro::State::clone cannot clone new or running states, caught"); if (coro->cctx) croak ("Coro::State::clone cannot clone a state running on a custom C context, caught"); /* TODO: maybe check slf_frame for prpeare_rransfer/check_nop? */ slot = coro->slot; if (slot->curstackinfo->si_type != PERLSI_MAIN) croak ("Coro::State::clone cannot clone a state running on a non-main stack, caught"); Newz (0, ncoro, 1, struct coro); Newz (0, nslot, 1, perl_slots); /* copy first, then fixup */ *ncoro = *coro; *nslot = *slot; ncoro->slot = nslot; nslot->curstackinfo = new_stackinfo (slot->stack_max - slot->stack_sp + 1, slot->curstackinfo->si_cxmax); nslot->curstackinfo->si_type = PERLSI_MAIN; nslot->curstackinfo->si_cxix = slot->curstackinfo->si_cxix; nslot->curstack = nslot->curstackinfo->si_stack; ncoro->mainstack = nslot->curstack; nslot->stack_base = AvARRAY (nslot->curstack); nslot->stack_sp = nslot->stack_base + (slot->stack_sp - slot->stack_base); nslot->stack_max = nslot->stack_base + AvMAX (nslot->curstack); Copy (slot->stack_base, nslot->stack_base, slot->stack_sp - slot->stack_base + 1, SV *); Copy (slot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxix + 1, PERL_CONTEXT); New (50, nslot->tmps_stack, nslot->tmps_max, SV *); Copy (slot->tmps_stack, nslot->tmps_stack, slot->tmps_ix + 1, SV *); New (54, nslot->markstack, slot->markstack_max - slot->markstack + 1, I32); nslot->markstack_ptr = nslot->markstack + (slot->markstack_ptr - slot->markstack); nslot->markstack_max = nslot->markstack + (slot->markstack_max - slot->markstack); Copy (slot->markstack, nslot->markstack, slot->markstack_ptr - slot->markstack + 1, I32); #ifdef SET_MARK_OFFSET //SET_MARK_OFFSET; /*TODO*/ #endif New (54, nslot->scopestack, slot->scopestack_max, I32); Copy (slot->scopestack, nslot->scopestack, slot->scopestack_ix + 1, I32); New (54, nslot->savestack, nslot->savestack_max, ANY); Copy (slot->savestack, nslot->savestack, slot->savestack_ix + 1, ANY); #if !PERL_VERSION_ATLEAST (5,10,0) New (54, nslot->retstack, nslot->retstack_max, OP *); Copy (slot->retstack, nslot->retstack, slot->retstack_max, OP *); #endif /* first fix up the padlists, by walking up our own saved state */ { SV **sp = nslot->stack_sp; AV *av; CV *cv; int i; /* now do the ugly restore mess */ while (expect_true (cv = (CV *)POPs)) { /* cv will be refcnt_inc'ed twice by the following two loops */ POPs; /* need to clone the padlist */ /* this simplistic hack is most likely wrong */ av = clone_av (aTHX_ (AV *)TOPs); AvREAL_off (av); for (i = 1; i <= AvFILLp (av); ++i) { SvREFCNT_dec (AvARRAY (av)[i]); AvARRAY (av)[i] = (SV *)clone_av (aTHX_ (AV *)AvARRAY (av)[i]); AvREIFY_only (AvARRAY (av)[i]); } TOPs = (SV *)av; POPs; } } /* easy things first, mortals */ { int i; for (i = 0; i <= nslot->tmps_ix; ++i) SvREFCNT_inc (nslot->tmps_stack [i]); } /* now fix up the context stack, modelled after cx_dup */ { I32 cxix = nslot->curstackinfo->si_cxix; PERL_CONTEXT *ccstk = nslot->curstackinfo->si_cxstack; while (expect_true (cxix >= 0)) { PERL_CONTEXT *cx = &ccstk[cxix--]; switch (CxTYPE (cx)) { case CXt_SUBST: croak ("Coro::State::clone cannot clone a state inside a substitution context, caught"); case CXt_SUB: if (cx->blk_sub.olddepth == 0) SvREFCNT_inc ((SV *)cx->blk_sub.cv); if (cx->blk_sub.hasargs) { SvREFCNT_inc ((SV *)cx->blk_sub.argarray); SvREFCNT_inc ((SV *)cx->blk_sub.savearray); } break; case CXt_EVAL: SvREFCNT_inc ((SV *)cx->blk_eval.old_namesv); SvREFCNT_inc ((SV *)cx->blk_eval.cur_text); break; case CXt_LOOP: /*TODO: cx->blk_loop.iterdata*/ SvREFCNT_inc ((SV *)cx->blk_loop.itersave); SvREFCNT_inc ((SV *)cx->blk_loop.iterlval); SvREFCNT_inc ((SV *)cx->blk_loop.iterary); break; case CXt_FORMAT: croak ("Coro::State::clone cannot clone a state inside a format, caught"); break; /* BLOCK, NULL etc. */ } } } /* now fix up the save stack */ /* modelled after ss_dup */ #define POPINT(ss,ix) ((ss)[--(ix)].any_i32) #define TOPINT(ss,ix) ((ss)[ix].any_i32) #define POPLONG(ss,ix) ((ss)[--(ix)].any_long) #define TOPLONG(ss,ix) ((ss)[ix].any_long) #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) #define TOPIV(ss,ix) ((ss)[ix].any_iv) #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) { ANY * const ss = nslot->savestack; const I32 max = nslot->savestack_max; I32 ix = nslot->savestack_ix; void *any_ptr; while (ix > 0) { const I32 type = POPINT (ss, ix); switch (type) { case SAVEt_HELEM: /* hash element */ SvREFCNT_inc ((SV *) POPPTR (ss, ix)); /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ SvREFCNT_inc ((SV *) POPPTR (ss, ix)); /* fall through */ case SAVEt_FREESV: case SAVEt_MORTALIZESV: SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_SHARED_PVREF: /* char* in shared space */ abort (); #if 0 c = (char *) POPPTR (ss, ix); TOPPTR (ss, ix) = savesharedpv (c); ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = any_dup (ptr, proto_perl); #endif break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ SvREFCNT_inc ((SV *) POPPTR (ss, ix)); POPPTR (ss, ix); break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ SvREFCNT_inc ((SV *) POPPTR (ss, ix)); /* fall through */ case SAVEt_COMPPAD: case SAVEt_NSTAB: SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_INT: /* int reference */ POPPTR (ss, ix); POPINT (ss, ix); break; case SAVEt_LONG: /* long reference */ POPPTR (ss, ix); /* fall through */ case SAVEt_CLEARSV: POPLONG (ss, ix); break; case SAVEt_I32: /* I32 reference */ case SAVEt_I16: /* I16 reference */ case SAVEt_I8: /* I8 reference */ case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ POPPTR (ss, ix); POPINT (ss, ix); break; case SAVEt_IV: /* IV reference */ POPPTR (ss, ix); POPIV (ss, ix); break; case SAVEt_HPTR: /* HV* reference */ case SAVEt_APTR: /* AV* reference */ case SAVEt_SPTR: /* SV* reference */ POPPTR (ss, ix); SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_VPTR: /* random* reference */ POPPTR (ss, ix); POPPTR (ss, ix); break; case SAVEt_GENERIC_PVREF: /* generic char* */ case SAVEt_PPTR: /* char* reference */ POPPTR (ss, ix); any_ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = savepv ((char *) any_ptr); break; case SAVEt_GP: /* scalar reference */ ((GP *) POPPTR (ss, ix))->gp_refcnt++; SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_FREEOP: abort (); #if 0 ptr = POPPTR (ss, ix); if (ptr && (((OP *) ptr)->op_private & OPpREFCOUNTED)) { /* these are assumed to be refcounted properly */ OP *o; switch (((OP *) ptr)->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: TOPPTR (ss, ix) = ptr; o = (OP *) ptr; OP_REFCNT_LOCK; (void) OpREFCNT_inc (o); OP_REFCNT_UNLOCK; break; default: TOPPTR (ss, ix) = NULL; break; } } else TOPPTR (ss, ix) = NULL; #endif break; case SAVEt_FREEPV: any_ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = savepv ((char *) any_ptr); break; case SAVEt_DELETE: SvREFCNT_inc ((SV *) POPPTR (ss, ix)); any_ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = savepv ((char *) any_ptr); /* fall through */ case SAVEt_STACK_POS: /* Position on Perl stack */ POPINT (ss, ix); break; case SAVEt_DESTRUCTOR: POPPTR (ss, ix); POPDPTR (ss, ix); break; case SAVEt_DESTRUCTOR_X: POPPTR (ss, ix); POPDXPTR (ss, ix); break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: { I32 ni = POPINT (ss, ix); ix = ni; } break; case SAVEt_AELEM: /* array element */ SvREFCNT_inc ((SV *) POPPTR (ss, ix)); POPINT (ss, ix); SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_OP: POPPTR (ss, ix); break; case SAVEt_HINTS: abort (); #if 0 { int i = POPINT (ss, ix); void *ptr = POPPTR (ss, ix); if (ptr) ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; if (i & HINT_LOCALIZE_HH) SvREFCNT_inc ((SV *) POPPTR (ss, ix)); } #endif break; case SAVEt_PADSV: POPLONG (ss, ix); POPPTR (ss, ix); SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_BOOL: POPPTR (ss, ix); POPBOOL (ss, ix); break; case SAVEt_SET_SVFLAGS: POPINT (ss, ix); POPINT (ss, ix); SvREFCNT_inc ((SV *) POPPTR (ss, ix)); break; case SAVEt_RE_STATE: abort (); #if 0 { const struct re_save_state *const old_state = (struct re_save_state *) (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); struct re_save_state *const new_state = (struct re_save_state *) (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); Copy (old_state, new_state, 1, struct re_save_state); ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; new_state->re_state_bostr = pv_dup (old_state->re_state_bostr); new_state->re_state_reginput = pv_dup (old_state->re_state_reginput); new_state->re_state_regeol = pv_dup (old_state->re_state_regeol); new_state->re_state_regoffs = (regexp_paren_pair *) any_dup (old_state->re_state_regoffs, proto_perl); new_state->re_state_reglastparen = (U32 *) any_dup (old_state->re_state_reglastparen, proto_perl); new_state->re_state_reglastcloseparen = (U32 *) any_dup (old_state->re_state_reglastcloseparen, proto_perl); /* XXX This just has to be broken. The old save_re_context code did SAVEGENERICPV(PL_reg_start_tmp); PL_reg_start_tmp is char **. Look above to what the dup code does for SAVEt_GENERIC_PVREF It can never have worked. So this is merely a faithful copy of the exiting bug: */ new_state->re_state_reg_start_tmp = (char **) pv_dup ((char *) old_state->re_state_reg_start_tmp); /* I assume that it only ever "worked" because no-one called (pseudo)fork while the regexp engine had re-entered itself. */ #ifdef PERL_OLD_COPY_ON_WRITE new_state->re_state_nrs = sv_dup (old_state->re_state_nrs, param); #endif new_state->re_state_reg_magic = (MAGIC *) any_dup (old_state->re_state_reg_magic, proto_perl); new_state->re_state_reg_oldcurpm = (PMOP *) any_dup (old_state->re_state_reg_oldcurpm, proto_perl); new_state->re_state_reg_curpm = (PMOP *) any_dup (old_state->re_state_reg_curpm, proto_perl); new_state->re_state_reg_oldsaved = pv_dup (old_state->re_state_reg_oldsaved); new_state->re_state_reg_poscache = pv_dup (old_state->re_state_reg_poscache); new_state->re_state_reg_starttry = pv_dup (old_state->re_state_reg_starttry); break; } #endif case SAVEt_COMPILE_WARNINGS: abort (); #if 0 ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = DUP_WARNINGS ((STRLEN *) ptr); break; #endif case SAVEt_PARSER: abort (); #if 0 ptr = POPPTR (ss, ix); TOPPTR (ss, ix) = parser_dup ((const yy_parser *) ptr, param); break; #endif default: croak ("panic: ss_dup inconsistency (%" IVdf ")", (IV) type); } } } SvREFCNT_inc (nslot->defsv); SvREFCNT_inc (nslot->defav); SvREFCNT_inc (nslot->errsv); SvREFCNT_inc (nslot->irsgv); SvREFCNT_inc (nslot->defoutgv); SvREFCNT_inc (nslot->rs); SvREFCNT_inc (nslot->compcv); SvREFCNT_inc (nslot->diehook); SvREFCNT_inc (nslot->warnhook); SvREFCNT_inc (ncoro->startcv); SvREFCNT_inc (ncoro->args); SvREFCNT_inc (ncoro->except); return ncoro; } Coro-6.57/Coro/State.xs0000644000000000000000000033514013633654074013432 0ustar rootroot/* this works around a bug in mingw32 providing a non-working setjmp */ #define USE_NO_MINGW_SETJMP_TWO_ARGS #define NDEBUG 1 /* perl usually disables NDEBUG later */ #include "libcoro/coro.c" #if CORO_UCONTEXT #define CORO_BACKEND "ucontext" #elif CORO_SJLJ #define CORO_BACKEND "sjlj" #elif CORO_LINUX #define CORO_BACKEND "linux" #elif CORO_LOSER #define CORO_BACKEND "loser" #elif CORO_FIBER #define CORO_BACKEND "fiber" #elif CORO_IRIX #define CORO_BACKEND "irix" #elif CORO_ASM #define CORO_BACKEND "asm" #elif CORO_PTHREAD #define CORO_BACKEND "pthread" #else #define CORO_BACKEND "unknown" #endif #define PERL_NO_GET_CONTEXT #define PERL_EXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "perliol.h" #include "schmorp.h" #define ECB_NO_THREADS 1 #define ECB_NO_LIBM 1 #include "ecb.h" #include #include #include #include #ifndef SvREFCNT_dec_NN #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv) #endif #ifndef SvREFCNT_inc_NN #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv) #endif #ifndef SVs_PADSTALE # define SVs_PADSTALE 0 #endif #ifdef PadARRAY # define NEWPADAPI 1 # define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *)) #else typedef AV PADNAMELIST; # if !PERL_VERSION_ATLEAST(5,8,0) typedef AV PADLIST; typedef AV PAD; # endif # define PadlistARRAY(pl) ((PAD **)AvARRAY (pl)) # define PadlistMAX(pl) AvFILLp (pl) # define PadlistNAMES(pl) (*PadlistARRAY (pl)) # define PadARRAY AvARRAY # define PadMAX AvFILLp # define newPADLIST(var) ((var) = newAV (), av_extend (var, 1)) #endif #ifndef PadnamelistREFCNT # define PadnamelistREFCNT(pnl) SvREFCNT (pnl) #endif #ifndef PadnamelistREFCNT_dec # define PadnamelistREFCNT_dec(pnl) SvREFCNT_dec (pnl) #endif /* 5.19.something has replaced SVt_BIND by SVt_INVLIST */ /* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */ #if PERL_VERSION_ATLEAST(5,19,0) # define SVt_BIND SVt_IV #endif #if defined(_WIN32) # undef HAS_GETTIMEOFDAY # undef setjmp # undef longjmp # undef _exit # define setjmp _setjmp /* deep magic */ #else # include /* most portable stdint.h */ #endif /* the maximum number of idle cctx that will be pooled */ static int cctx_max_idle = 4; #if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0) # define HAS_SCOPESTACK_NAME 1 #endif /* prefer perl internal functions over our own? */ #ifndef CORO_PREFER_PERL_FUNCTIONS # define CORO_PREFER_PERL_FUNCTIONS 0 #endif /* The next macros try to return the current stack pointer, in an as * portable way as possible. */ #if __GNUC__ >= 4 # define dSTACKLEVEL int stacklevel_dummy # define STACKLEVEL __builtin_frame_address (0) #else # define dSTACKLEVEL volatile void *stacklevel # define STACKLEVEL ((void *)&stacklevel) #endif #define IN_DESTRUCT PL_dirty #include "CoroAPI.h" #define GCoroAPI (&coroapi) /* very sneaky */ #ifdef USE_ITHREADS # if CORO_PTHREAD static void *coro_thx; # endif #endif #ifdef __linux # include /* for timespec */ # include /* for SYS_* */ # ifdef SYS_clock_gettime # define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts)) # define CORO_CLOCK_MONOTONIC 1 # define CORO_CLOCK_THREAD_CPUTIME_ID 3 # endif #endif /* one off bugfix for perl 5.22 */ #if PERL_VERSION_ATLEAST(5,22,0) && !PERL_VERSION_ATLEAST(5,24,0) # undef PadlistNAMES # define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY (pl)) #endif #if PERL_VERSION_ATLEAST(5,24,0) # define SUB_ARGARRAY PL_curpad[0] #else # define SUB_ARGARRAY (SV *)cx->blk_sub.argarray #endif /* perl usually suppresses asserts. for debugging, we sometimes force it to be on */ #if 0 # undef NDEBUG # include #endif static double (*nvtime)(); /* so why doesn't it take void? */ static void (*u2time)(pTHX_ UV ret[2]); /* we hijack an hopefully unused CV flag for our purposes */ #define CVf_SLF 0x4000 static OP *pp_slf (pTHX); static void slf_destroy (pTHX_ struct coro *coro); static U32 cctx_gen; static size_t cctx_stacksize = CORO_STACKSIZE; static struct CoroAPI coroapi; static AV *main_mainstack; /* used to differentiate between $main and others */ static JMPENV *main_top_env; static HV *coro_state_stash, *coro_stash; static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */ static AV *av_destroy; /* destruction queue */ static SV *sv_manager; /* the manager coro */ static SV *sv_idle; /* $Coro::idle */ static GV *irsgv; /* $/ */ static GV *stdoutgv; /* *STDOUT */ static SV *rv_diehook; static SV *rv_warnhook; /* async_pool helper stuff */ static SV *sv_pool_rss; static SV *sv_pool_size; static SV *sv_async_pool_idle; /* description string */ static AV *av_async_pool; /* idle pool */ static SV *sv_Coro; /* class string */ static CV *cv_pool_handler; /* Coro::AnyEvent */ static SV *sv_activity; /* enable processtime/realtime profiling */ static char enable_times; typedef U32 coro_ts[2]; static coro_ts time_real, time_cpu; static char times_valid; static struct coro_cctx *cctx_first; static int cctx_count, cctx_idle; enum { CC_MAPPED = 0x01, CC_NOREUSE = 0x02, /* throw this away after tracing */ CC_TRACE = 0x04, CC_TRACE_SUB = 0x08, /* trace sub calls */ CC_TRACE_LINE = 0x10, /* trace each statement */ CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE, }; /* this is a structure representing a c-level coroutine */ typedef struct coro_cctx { struct coro_cctx *next; /* the stack */ struct coro_stack stack; /* cpu state */ void *idle_sp; /* sp of top-level transfer/schedule/cede call */ #ifndef NDEBUG JMPENV *idle_te; /* same as idle_sp, but for top_env */ #endif JMPENV *top_env; coro_context cctx; U32 gen; #if CORO_USE_VALGRIND int valgrind_id; #endif unsigned char flags; } coro_cctx; static coro_cctx *cctx_current; /* the currently running cctx */ /*****************************************************************************/ static MGVTBL coro_state_vtbl; enum { CF_RUNNING = 0x0001, /* coroutine is running */ CF_READY = 0x0002, /* coroutine is ready */ CF_NEW = 0x0004, /* has never been switched to */ CF_ZOMBIE = 0x0008, /* coroutine data has been freed */ CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */ CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */ }; /* the structure where most of the perl state is stored, overlaid on the cxstack */ typedef struct { #define VARx(name,expr,type) type name; #include "state.h" } perl_slots; /* how many context stack entries do we need for perl_slots */ #define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT)) /* this is a structure representing a perl-level coroutine */ struct coro { /* the C coroutine allocated to this perl coroutine, if any */ coro_cctx *cctx; /* ready queue */ struct coro *next_ready; /* state data */ struct CoroSLF slf_frame; /* saved slf frame */ AV *mainstack; perl_slots *slot; /* basically the saved sp */ CV *startcv; /* the CV to execute */ AV *args; /* data associated with this coroutine (initial args) */ int flags; /* CF_ flags */ HV *hv; /* the perl hash associated with this coro, if any */ /* statistics */ int usecount; /* number of transfers to this coro */ /* coro process data */ int prio; SV *except; /* exception to be thrown */ SV *rouse_cb; /* most recently created rouse callback */ AV *on_destroy; /* callbacks or coros to notify on destroy */ AV *status; /* the exit status list */ /* async_pool */ SV *saved_deffh; SV *invoke_cb; AV *invoke_av; /* on_enter/on_leave */ AV *on_enter; AV *on_enter_xs; AV *on_leave; AV *on_leave_xs; /* swap_sv */ AV *swap_sv; /* times */ coro_ts t_cpu, t_real; /* linked list */ struct coro *next, *prev; }; typedef struct coro *Coro__State; typedef struct coro *Coro__State_or_hashref; /* the following variables are effectively part of the perl context */ /* and get copied between struct coro and these variables */ /* the main reason we don't support windows process emulation */ static struct CoroSLF slf_frame; /* the current slf frame */ /** Coro ********************************************************************/ #define CORO_PRIO_MAX 3 #define CORO_PRIO_HIGH 1 #define CORO_PRIO_NORMAL 0 #define CORO_PRIO_LOW -1 #define CORO_PRIO_IDLE -3 #define CORO_PRIO_MIN -4 /* for Coro.pm */ static SV *coro_current; static SV *coro_readyhook; static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */ static CV *cv_coro_run; static struct coro *coro_first; #define coro_nready coroapi.nready /** JIT *********************************************************************/ #if CORO_JIT /* APPLE doesn't have mmap though */ #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__) #ifndef CORO_JIT_TYPE #if ECB_AMD64 && CORO_JIT_UNIXY #define CORO_JIT_TYPE "amd64-unix" #elif __i386 && CORO_JIT_UNIXY #define CORO_JIT_TYPE "x86-unix" #endif #endif #endif #if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0 #undef CORO_JIT #endif #if CORO_JIT typedef void (*load_save_perl_slots_type)(perl_slots *); static load_save_perl_slots_type load_perl_slots, save_perl_slots; #endif /** Coro::Select ************************************************************/ static OP *(*coro_old_pp_sselect) (pTHX); static SV *coro_select_select; /* horrible hack, but if it works... */ static OP * coro_pp_sselect (pTHX) { dSP; PUSHMARK (SP - 4); /* fake argument list */ XPUSHs (coro_select_select); PUTBACK; /* entersub is an UNOP, select a LISTOP... keep your fingers crossed */ PL_op->op_flags |= OPf_STACKED; PL_op->op_private = 0; return PL_ppaddr [OP_ENTERSUB](aTHX); } /** time stuff **************************************************************/ #ifdef HAS_GETTIMEOFDAY ecb_inline void coro_u2time (pTHX_ UV ret[2]) { struct timeval tv; gettimeofday (&tv, 0); ret [0] = tv.tv_sec; ret [1] = tv.tv_usec; } ecb_inline double coro_nvtime (void) { struct timeval tv; gettimeofday (&tv, 0); return tv.tv_sec + tv.tv_usec * 1e-6; } ecb_inline void time_init (pTHX) { nvtime = coro_nvtime; u2time = coro_u2time; } #else ecb_inline void time_init (pTHX) { SV **svp; require_pv ("Time/HiRes.pm"); svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0); if (!svp) croak ("Time::HiRes is required, but missing. Caught"); if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught"); nvtime = INT2PTR (double (*)(), SvIV (*svp)); svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0); u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp)); } #endif /** lowlevel stuff **********************************************************/ static SV * ecb_noinline coro_get_sv (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) /* silence stupid and wrong 5.10 warning that I am unable to switch off */ get_sv (name, create); #endif return get_sv (name, create); } static AV * ecb_noinline coro_get_av (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) /* silence stupid and wrong 5.10 warning that I am unable to switch off */ get_av (name, create); #endif return get_av (name, create); } static HV * ecb_noinline coro_get_hv (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) /* silence stupid and wrong 5.10 warning that I am unable to switch off */ get_hv (name, create); #endif return get_hv (name, create); } ecb_inline void coro_times_update (void) { #ifdef coro_clock_gettime struct timespec ts; ts.tv_sec = ts.tv_nsec = 0; coro_clock_gettime (CORO_CLOCK_THREAD_CPUTIME_ID, &ts); time_cpu [0] = ts.tv_sec; time_cpu [1] = ts.tv_nsec; ts.tv_sec = ts.tv_nsec = 0; coro_clock_gettime (CORO_CLOCK_MONOTONIC, &ts); time_real [0] = ts.tv_sec; time_real [1] = ts.tv_nsec; #else dTHX; UV tv[2]; u2time (aTHX_ tv); time_real [0] = tv [0]; time_real [1] = tv [1] * 1000; #endif } ecb_inline void coro_times_add (struct coro *c) { c->t_real [1] += time_real [1]; if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; } c->t_real [0] += time_real [0]; c->t_cpu [1] += time_cpu [1]; if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; } c->t_cpu [0] += time_cpu [0]; } ecb_inline void coro_times_sub (struct coro *c) { if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; } c->t_real [1] -= time_real [1]; c->t_real [0] -= time_real [0]; if (c->t_cpu [1] < time_cpu [1]) { c->t_cpu [1] += 1000000000; --c->t_cpu [0]; } c->t_cpu [1] -= time_cpu [1]; c->t_cpu [0] -= time_cpu [0]; } /*****************************************************************************/ /* magic glue */ #define CORO_MAGIC_type_cv 26 #define CORO_MAGIC_type_state PERL_MAGIC_ext #define CORO_MAGIC_NN(sv, type) \ (ecb_expect_true (SvMAGIC (sv)->mg_type == type) \ ? SvMAGIC (sv) \ : mg_find (sv, type)) #define CORO_MAGIC(sv, type) \ (ecb_expect_true (SvMAGIC (sv)) \ ? CORO_MAGIC_NN (sv, type) \ : 0) #define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv) #define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state) ecb_inline MAGIC * SvSTATEhv_p (pTHX_ SV *coro) { MAGIC *mg; if (ecb_expect_true ( SvTYPE (coro) == SVt_PVHV && (mg = CORO_MAGIC_state (coro)) && mg->mg_virtual == &coro_state_vtbl )) return mg; return 0; } ecb_inline struct coro * SvSTATE_ (pTHX_ SV *coro_sv) { MAGIC *mg; if (SvROK (coro_sv)) coro_sv = SvRV (coro_sv); mg = SvSTATEhv_p (aTHX_ coro_sv); if (!mg) croak ("Coro::State object required"); return (struct coro *)mg->mg_ptr; } #define SvSTATE(sv) SvSTATE_ (aTHX_ (sv)) /* faster than SvSTATE, but expects a coroutine hv */ #define SvSTATE_hv(hv) ((struct coro *)CORO_MAGIC_NN ((SV *)hv, CORO_MAGIC_type_state)->mg_ptr) #define SvSTATE_current SvSTATE_hv (SvRV (coro_current)) /*****************************************************************************/ /* padlist management and caching */ ecb_inline PADLIST * coro_derive_padlist (pTHX_ CV *cv) { PADLIST *padlist = CvPADLIST (cv); PADLIST *newpadlist; PADNAMELIST *padnames; PAD *newpad; PADOFFSET off = PadlistMAX (padlist) + 1; #if NEWPADAPI /* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */ /* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */ while (!PadlistARRAY (padlist)[off - 1]) --off; Perl_pad_push (aTHX_ padlist, off); newpad = PadlistARRAY (padlist)[off]; PadlistARRAY (padlist)[off] = 0; #else #if PERL_VERSION_ATLEAST (5,10,0) Perl_pad_push (aTHX_ padlist, off); #else Perl_pad_push (aTHX_ padlist, off, 1); #endif newpad = PadlistARRAY (padlist)[off]; PadlistMAX (padlist) = off - 1; #endif newPADLIST (newpadlist); #if !PERL_VERSION_ATLEAST(5,15,3) /* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */ AvREAL_off (newpadlist); #endif /* Already extended to 2 elements by newPADLIST. */ PadlistMAX (newpadlist) = 1; padnames = PadlistNAMES (padlist); ++PadnamelistREFCNT (padnames); PadlistNAMES (newpadlist) = padnames; PadlistARRAY (newpadlist)[1] = newpad; return newpadlist; } ecb_inline void free_padlist (pTHX_ PADLIST *padlist) { /* may be during global destruction */ if (!IN_DESTRUCT) { I32 i = PadlistMAX (padlist); while (i > 0) /* special-case index 0 */ { /* we try to be extra-careful here */ PAD *pad = PadlistARRAY (padlist)[i--]; if (pad) { I32 j = PadMAX (pad); while (j >= 0) SvREFCNT_dec (PadARRAY (pad)[j--]); PadMAX (pad) = -1; SvREFCNT_dec (pad); } } PadnamelistREFCNT_dec (PadlistNAMES (padlist)); #if NEWPADAPI Safefree (PadlistARRAY (padlist)); Safefree (padlist); #else AvFILLp (padlist) = -1; AvREAL_off (padlist); SvREFCNT_dec ((SV*)padlist); #endif } } static int coro_cv_free (pTHX_ SV *sv, MAGIC *mg) { PADLIST *padlist; PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t)); size_t len = *(size_t *)mg->mg_ptr; /* perl manages to free our internal AV and _then_ call us */ if (IN_DESTRUCT) return 0; while (len--) free_padlist (aTHX_ padlists[len]); return 0; } static MGVTBL coro_cv_vtbl = { 0, 0, 0, 0, coro_cv_free }; /* the next two functions merely cache the padlists */ ecb_inline void get_padlist (pTHX_ CV *cv) { MAGIC *mg = CORO_MAGIC_cv (cv); size_t *lenp; if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr))) CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp]; else { #if CORO_PREFER_PERL_FUNCTIONS /* this is probably cleaner? but also slower! */ /* in practise, it seems to be less stable */ CV *cp = Perl_cv_clone (aTHX_ cv); CvPADLIST (cv) = CvPADLIST (cp); CvPADLIST (cp) = 0; SvREFCNT_dec (cp); #else CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv); #endif } } ecb_inline void put_padlist (pTHX_ CV *cv) { MAGIC *mg = CORO_MAGIC_cv (cv); if (ecb_expect_false (!mg)) { mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0); Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char); mg->mg_len = 1; /* so mg_free frees mg_ptr */ } else Renew (mg->mg_ptr, sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *), char); ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv); } /** load & save, init *******************************************************/ ecb_inline void swap_sv (SV *a, SV *b) { const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */ SV tmp; /* swap sv_any */ SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp); /* swap sv_flags */ SvFLAGS (&tmp) = SvFLAGS (a); SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep); SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep); #if PERL_VERSION_ATLEAST (5,10,0) /* perl 5.10 and later complicates this _quite_ a bit, but it also * is much faster, so no quarrels here. alternatively, we could * sv_upgrade to avoid this. */ { /* swap sv_u */ tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u; /* if SvANY points to the head, we need to adjust the pointers, * as the pointer for a still points to b, and maybe vice versa. */ U32 svany_in_head_set = (1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV); #if NVSIZE <= IVSIZE && PERL_VERSION_ATLEAST(5,22,0) svany_in_head_set |= 1 << SVt_NV; #endif #define svany_in_head(type) (svany_in_head_set & (1 << (type))) if (svany_in_head (SvTYPE (a))) SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a); if (svany_in_head (SvTYPE (b))) SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b); } #endif } /* swap sv heads, at least logically */ static void swap_svs_enter (pTHX_ Coro__State c) { int i; for (i = 0; i <= AvFILLp (c->swap_sv); i += 2) swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]); } static void swap_svs_leave (pTHX_ Coro__State c) { int i; for (i = AvFILLp (c->swap_sv) - 1; i >= 0; i -= 2) swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]); } #define SWAP_SVS_ENTER(coro) \ if (ecb_expect_false ((coro)->swap_sv)) \ swap_svs_enter (aTHX_ (coro)) #define SWAP_SVS_LEAVE(coro) \ if (ecb_expect_false ((coro)->swap_sv)) \ swap_svs_leave (aTHX_ (coro)) static void on_enterleave_call (pTHX_ SV *cb); static void load_perl (pTHX_ Coro__State c) { perl_slots *slot = c->slot; c->slot = 0; PL_mainstack = c->mainstack; #if CORO_JIT load_perl_slots (slot); #else #define VARx(name,expr,type) expr = slot->name; #include "state.h" #endif { dSP; CV *cv; /* now do the ugly restore mess */ while (ecb_expect_true (cv = (CV *)POPs)) { put_padlist (aTHX_ cv); /* mark this padlist as available */ CvDEPTH (cv) = PTR2IV (POPs); CvPADLIST (cv) = (PADLIST *)POPs; } PUTBACK; } slf_frame = c->slf_frame; CORO_THROW = c->except; if (ecb_expect_false (enable_times)) { if (ecb_expect_false (!times_valid)) coro_times_update (); coro_times_sub (c); } if (ecb_expect_false (c->on_enter)) { int i; for (i = 0; i <= AvFILLp (c->on_enter); ++i) on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]); } if (ecb_expect_false (c->on_enter_xs)) { int i; for (i = 0; i <= AvFILLp (c->on_enter_xs); i += 2) ((coro_enterleave_hook)AvARRAY (c->on_enter_xs)[i]) (aTHX_ AvARRAY (c->on_enter_xs)[i + 1]); } SWAP_SVS_ENTER (c); } static void save_perl (pTHX_ Coro__State c) { SWAP_SVS_LEAVE (c); if (ecb_expect_false (c->on_leave_xs)) { int i; for (i = AvFILLp (c->on_leave_xs) - 1; i >= 0; i -= 2) ((coro_enterleave_hook)AvARRAY (c->on_leave_xs)[i]) (aTHX_ AvARRAY (c->on_leave_xs)[i + 1]); } if (ecb_expect_false (c->on_leave)) { int i; for (i = AvFILLp (c->on_leave); i >= 0; --i) on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]); } times_valid = 0; if (ecb_expect_false (enable_times)) { coro_times_update (); times_valid = 1; coro_times_add (c); } c->except = CORO_THROW; c->slf_frame = slf_frame; { dSP; I32 cxix = cxstack_ix; PERL_CONTEXT *ccstk = cxstack; PERL_SI *top_si = PL_curstackinfo; /* * the worst thing you can imagine happens first - we have to save * (and reinitialize) all cv's in the whole callchain :( */ XPUSHs (Nullsv); /* this loop was inspired by pp_caller */ for (;;) { while (ecb_expect_true (cxix >= 0)) { PERL_CONTEXT *cx = &ccstk[cxix--]; if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT)) { CV *cv = cx->blk_sub.cv; if (ecb_expect_true (CvDEPTH (cv))) { EXTEND (SP, 3); PUSHs ((SV *)CvPADLIST (cv)); PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv))); PUSHs ((SV *)cv); CvDEPTH (cv) = 0; get_padlist (aTHX_ cv); } } } if (ecb_expect_true (top_si->si_type == PERLSI_MAIN)) break; top_si = top_si->si_prev; ccstk = top_si->si_cxstack; cxix = top_si->si_cxix; } PUTBACK; } /* allocate some space on the context stack for our purposes */ if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max)) { unsigned int i; for (i = 0; i < SLOT_COUNT; ++i) CXINC; cxstack_ix -= SLOT_COUNT; /* undo allocation */ } c->mainstack = PL_mainstack; { perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1); #if CORO_JIT save_perl_slots (slot); #else #define VARx(name,expr,type) slot->name = expr; #include "state.h" #endif } } /* * allocate various perl stacks. This is almost an exact copy * of perl.c:init_stacks, except that it uses less memory * on the (sometimes correct) assumption that coroutines do * not usually need a lot of stackspace. */ #if CORO_PREFER_PERL_FUNCTIONS # define coro_init_stacks(thx) init_stacks () #else static void coro_init_stacks (pTHX) { PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */ PL_curstackinfo->si_type = PERLSI_MAIN; PL_curstack = PL_curstackinfo->si_stack; PL_mainstack = PL_curstack; /* remember in case we switch stacks */ PL_stack_base = AvARRAY(PL_curstack); PL_stack_sp = PL_stack_base; PL_stack_max = PL_stack_base + AvMAX(PL_curstack); New(50,PL_tmps_stack,32,SV*); PL_tmps_floor = -1; PL_tmps_ix = -1; PL_tmps_max = 32; New(54,PL_markstack,16,I32); PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + 16; #ifdef SET_MARK_OFFSET SET_MARK_OFFSET; #endif New(54,PL_scopestack,8,I32); PL_scopestack_ix = 0; PL_scopestack_max = 8; #if HAS_SCOPESTACK_NAME New(54,PL_scopestack_name,8,const char*); #endif New(54,PL_savestack,24,ANY); PL_savestack_ix = 0; PL_savestack_max = 24; #if PERL_VERSION_ATLEAST (5,24,0) /* perl 5.24 moves SS_MAXPUSH optimisation from */ /* the header macros to PL_savestack_max */ PL_savestack_max -= SS_MAXPUSH; #endif #if !PERL_VERSION_ATLEAST (5,10,0) New(54,PL_retstack,4,OP*); PL_retstack_ix = 0; PL_retstack_max = 4; #endif } #endif /* * destroy the stacks, the callchain etc... */ static void coro_destruct_stacks (pTHX) { while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { PERL_SI *p = PL_curstackinfo->si_prev; if (!IN_DESTRUCT) SvREFCNT_dec (PL_curstackinfo->si_stack); Safefree (PL_curstackinfo->si_cxstack); Safefree (PL_curstackinfo); PL_curstackinfo = p; } Safefree (PL_tmps_stack); Safefree (PL_markstack); Safefree (PL_scopestack); #if HAS_SCOPESTACK_NAME Safefree (PL_scopestack_name); #endif Safefree (PL_savestack); #if !PERL_VERSION_ATLEAST (5,10,0) Safefree (PL_retstack); #endif } #define CORO_RSS \ rss += sizeof (SYM (curstackinfo)); \ rss += (SYM (curstackinfo->si_cxmax) + 1) * sizeof (PERL_CONTEXT); \ rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (SYM (curstack))) * sizeof (SV *); \ rss += SYM (tmps_max) * sizeof (SV *); \ rss += (SYM (markstack_max) - SYM (markstack_ptr)) * sizeof (I32); \ rss += SYM (scopestack_max) * sizeof (I32); \ rss += SYM (savestack_max) * sizeof (ANY); static size_t coro_rss (pTHX_ struct coro *coro) { size_t rss = sizeof (*coro); if (coro->mainstack) { if (coro->flags & CF_RUNNING) { #define SYM(sym) PL_ ## sym CORO_RSS; #undef SYM } else { #define SYM(sym) coro->slot->sym CORO_RSS; #undef SYM } } return rss; } /** provide custom get/set/clear methods for %SIG elements ******************/ /* apparently < 5.8.8 */ #ifndef MgPV_nolen_const #define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \ SvPV_nolen((SV*)((mg)->mg_ptr)) : \ (const char*)(mg)->mg_ptr) #endif /* this will be a patched copy of PL_vtbl_sigelem */ static MGVTBL coro_sigelem_vtbl; static int ecb_cold coro_sig_copy (pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, I32 namlen) { char *key = SvPV_nolen ((SV *)name); /* do what mg_copy normally does */ sv_magic (nsv, mg->mg_obj, PERL_MAGIC_sigelem, name, namlen); assert (mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual == &PL_vtbl_sigelem); /* patch sigelem vtbl, but only for __WARN__ and __DIE__ */ if (*key == '_' && (strEQ (key, "__DIE__") || strEQ (key, "__WARN__"))) mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual = &coro_sigelem_vtbl; return 1; } /* perl does not have a %SIG vtbl, we provide one so we can override */ /* the magic vtbl for the __DIE__ and __WARN__ members */ static const MGVTBL coro_sig_vtbl = { 0, 0, 0, 0, 0, coro_sig_copy }; /* * This overrides the default magic get method of %SIG elements. * The original one doesn't provide for reading back of PL_diehook/PL_warnhook * and instead of trying to save and restore the hash elements (extremely slow), * we just provide our own readback here. */ static int ecb_cold coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); /* the key must be either __DIE__ or __WARN__ here */ SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook; SV *ssv; if (!*svp) ssv = &PL_sv_undef; else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */ ssv = sv_2mortal (newRV_inc (*svp)); else ssv = *svp; sv_setsv (sv, ssv); return 0; } static int ecb_cold coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); /* the key must be either __DIE__ or __WARN__ here */ SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook; SV *old = *svp; *svp = 0; SvREFCNT_dec (old); return 0; } static int ecb_cold coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); /* the key must be either __DIE__ or __WARN__ here */ SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook; SV *old = *svp; *svp = SvOK (sv) ? newSVsv (sv) : 0; SvREFCNT_dec (old); return 0; } static void prepare_nop (pTHX_ struct coro_transfer_args *ta) { /* kind of mega-hacky, but works */ ta->next = ta->prev = (struct coro *)ta; } static int slf_check_nop (pTHX_ struct CoroSLF *frame) { return 0; } static int slf_check_repeat (pTHX_ struct CoroSLF *frame) { return 1; } /** coroutine stack handling ************************************************/ static UNOP init_perl_op; ecb_noinline static void /* noinline to keep it out of the transfer fast path */ init_perl (pTHX_ struct coro *coro) { /* * emulate part of the perl startup here. */ coro_init_stacks (aTHX); PL_runops = RUNOPS_DEFAULT; PL_curcop = &PL_compiling; PL_in_eval = EVAL_NULL; PL_comppad = 0; PL_comppad_name = 0; PL_comppad_name_fill = 0; PL_comppad_name_floor = 0; PL_curpm = 0; PL_curpad = 0; PL_localizing = 0; PL_restartop = 0; #if PERL_VERSION_ATLEAST (5,10,0) PL_parser = 0; #endif PL_hints = 0; /* recreate the die/warn hooks */ PL_diehook = SvREFCNT_inc (rv_diehook); PL_warnhook = SvREFCNT_inc (rv_warnhook); GvSV (PL_defgv) = newSV (0); GvAV (PL_defgv) = coro->args; coro->args = 0; GvSV (PL_errgv) = newSV (0); GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0); GvHV (PL_hintgv) = newHV (); #if PERL_VERSION_ATLEAST (5,10,0) hv_magic (GvHV (PL_hintgv), 0, PERL_MAGIC_hints); #endif PL_rs = newSVsv (GvSV (irsgv)); PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv); { dSP; UNOP myop; Zero (&myop, 1, UNOP); myop.op_next = Nullop; myop.op_type = OP_ENTERSUB; myop.op_flags = OPf_WANT_VOID; PUSHMARK (SP); XPUSHs ((SV *)coro->startcv); PUTBACK; PL_op = (OP *)&myop; PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); } /* this newly created coroutine might be run on an existing cctx which most * likely was suspended in pp_slf, so we have to emulate entering pp_slf here. */ slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */ slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */ slf_frame.destroy = 0; /* and we have to provide the pp_slf op in any case, so pp_slf can skip it */ init_perl_op.op_next = PL_op; init_perl_op.op_type = OP_ENTERSUB; init_perl_op.op_ppaddr = pp_slf; /* no flags etc. required, as an init function won't be called */ PL_op = (OP *)&init_perl_op; /* copy throw, in case it was set before init_perl */ CORO_THROW = coro->except; SWAP_SVS_ENTER (coro); if (ecb_expect_false (enable_times)) { coro_times_update (); coro_times_sub (coro); } } static void coro_unwind_stacks (pTHX) { if (!IN_DESTRUCT) { /* restore all saved variables and stuff */ LEAVE_SCOPE (0); assert (PL_tmps_floor == -1); /* free all temporaries */ FREETMPS; assert (PL_tmps_ix == -1); /* unwind all extra stacks */ POPSTACK_TO (PL_mainstack); /* unwind main stack */ dounwind (-1); } } static void destroy_perl (pTHX_ struct coro *coro) { SV *svf [9]; { SV *old_current = SvRV (coro_current); struct coro *current = SvSTATE (old_current); assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack)); save_perl (aTHX_ current); /* this will cause transfer_check to croak on block*/ SvRV_set (coro_current, (SV *)coro->hv); load_perl (aTHX_ coro); /* restore swapped sv's */ SWAP_SVS_LEAVE (coro); coro_unwind_stacks (aTHX); coro_destruct_stacks (aTHX); /* now save some sv's to be free'd later */ svf [0] = GvSV (PL_defgv); svf [1] = (SV *)GvAV (PL_defgv); svf [2] = GvSV (PL_errgv); svf [3] = (SV *)PL_defoutgv; svf [4] = PL_rs; svf [5] = GvSV (irsgv); svf [6] = (SV *)GvHV (PL_hintgv); svf [7] = PL_diehook; svf [8] = PL_warnhook; assert (9 == sizeof (svf) / sizeof (*svf)); SvRV_set (coro_current, old_current); load_perl (aTHX_ current); } { unsigned int i; for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i) SvREFCNT_dec (svf [i]); SvREFCNT_dec (coro->saved_deffh); SvREFCNT_dec (coro->rouse_cb); SvREFCNT_dec (coro->invoke_cb); SvREFCNT_dec (coro->invoke_av); SvREFCNT_dec (coro->on_enter_xs); SvREFCNT_dec (coro->on_leave_xs); } } ecb_inline void free_coro_mortal (pTHX) { if (ecb_expect_true (coro_mortal)) { SvREFCNT_dec ((SV *)coro_mortal); coro_mortal = 0; } } static int runops_trace (pTHX) { COP *oldcop = 0; int oldcxix = -2; while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX))) { PERL_ASYNC_CHECK (); if (cctx_current->flags & CC_TRACE_ALL) { if (PL_op->op_type == OP_LEAVESUB && cctx_current->flags & CC_TRACE_SUB) { PERL_CONTEXT *cx = &cxstack[cxstack_ix]; SV **bot, **top; AV *av = newAV (); /* return values */ SV **cb; dSP; GV *gv = CvGV (cx->blk_sub.cv); SV *fullname = sv_2mortal (newSV (0)); if (isGV (gv)) gv_efullname3 (fullname, gv, 0); bot = PL_stack_base + cx->blk_oldsp + 1; top = cx->blk_gimme == G_ARRAY ? SP + 1 : cx->blk_gimme == G_SCALAR ? bot + 1 : bot; av_extend (av, top - bot); while (bot < top) av_push (av, SvREFCNT_inc_NN (*bot++)); PL_runops = RUNOPS_DEFAULT; ENTER; SAVETMPS; PUSHMARK (SP); EXTEND (SP, 3); PUSHs (&PL_sv_no); PUSHs (fullname); PUSHs (sv_2mortal (newRV_noinc ((SV *)av))); PUTBACK; cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0); if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); SPAGAIN; FREETMPS; LEAVE; PL_runops = runops_trace; } if (oldcop != PL_curcop) { oldcop = PL_curcop; if (PL_curcop != &PL_compiling) { SV **cb; if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB && cxstack_ix >= 0) { PERL_CONTEXT *cx = &cxstack[cxstack_ix]; if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix) { dSP; GV *gv = CvGV (cx->blk_sub.cv); SV *fullname = sv_2mortal (newSV (0)); if (isGV (gv)) gv_efullname3 (fullname, gv, 0); PL_runops = RUNOPS_DEFAULT; ENTER; SAVETMPS; PUSHMARK (SP); EXTEND (SP, 3); PUSHs (&PL_sv_yes); PUSHs (fullname); PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc (SUB_ARGARRAY)) : &PL_sv_undef); PUTBACK; cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0); if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); SPAGAIN; FREETMPS; LEAVE; PL_runops = runops_trace; } oldcxix = cxstack_ix; } if (cctx_current->flags & CC_TRACE_LINE) { dSP; PL_runops = RUNOPS_DEFAULT; ENTER; SAVETMPS; PUSHMARK (SP); EXTEND (SP, 2); PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0))); PUSHs (sv_2mortal (newSViv (CopLINE (oldcop)))); PUTBACK; cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0); if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); SPAGAIN; FREETMPS; LEAVE; PL_runops = runops_trace; } } } } } TAINT_NOT; return 0; } static struct CoroSLF cctx_ssl_frame; static void slf_prepare_set_stacklevel (pTHX_ struct coro_transfer_args *ta) { ta->prev = 0; } static int slf_check_set_stacklevel (pTHX_ struct CoroSLF *frame) { *frame = cctx_ssl_frame; return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */ } /* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */ static void ecb_noinline cctx_prepare (pTHX) { PL_top_env = &PL_start_env; if (cctx_current->flags & CC_TRACE) PL_runops = runops_trace; /* we already must be executing an SLF op, there is no other valid way * that can lead to creation of a new cctx */ assert (("FATAL: can't prepare slf-less cctx in Coro module (please report)", slf_frame.prepare && PL_op->op_ppaddr == pp_slf)); /* we must emulate leaving pp_slf, which is done inside slf_check_set_stacklevel */ cctx_ssl_frame = slf_frame; slf_frame.prepare = slf_prepare_set_stacklevel; slf_frame.check = slf_check_set_stacklevel; } /* the tail of transfer: execute stuff we can only do after a transfer */ ecb_inline void transfer_tail (pTHX) { free_coro_mortal (aTHX); } /* try to exit the same way perl's main function would do */ /* we do not bother resetting the environment or other things *7 /* that are not, uhm, essential */ /* this obviously also doesn't work when perl is embedded */ static void ecb_noinline ecb_cold perlish_exit (pTHX) { int exitstatus = perl_destruct (PL_curinterp); perl_free (PL_curinterp); exit (exitstatus); } /* * this is a _very_ stripped down perl interpreter ;) */ static void cctx_run (void *arg) { #ifdef USE_ITHREADS # if CORO_PTHREAD PERL_SET_CONTEXT (coro_thx); # endif #endif { dTHX; /* normally we would need to skip the entersub here */ /* not doing so will re-execute it, which is exactly what we want */ /* PL_nop = PL_nop->op_next */ /* inject a fake subroutine call to cctx_init */ cctx_prepare (aTHX); /* cctx_run is the alternative tail of transfer() */ transfer_tail (aTHX); /* somebody or something will hit me for both perl_run and PL_restartop */ PL_restartop = PL_op; perl_run (PL_curinterp); /* * Unfortunately, there is no way to get at the return values of the * coro body here, as perl_run destroys these. Likewise, we cannot catch * runtime errors here, as this is just a random interpreter, not a thread. */ /* * pp_entersub in 5.24 no longer ENTERs, but perl_destruct * requires PL_scopestack_ix, so do it here if required. */ if (!PL_scopestack_ix) ENTER; /* * If perl-run returns we assume exit() was being called or the coro * fell off the end, which seems to be the only valid (non-bug) * reason for perl_run to return. We try to mimic whatever perl is normally * doing in that case. YMMV. */ perlish_exit (aTHX); } } static coro_cctx * cctx_new (void) { coro_cctx *cctx; ++cctx_count; New (0, cctx, 1, coro_cctx); cctx->gen = cctx_gen; cctx->flags = 0; cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */ return cctx; } /* create a new cctx only suitable as source */ static coro_cctx * cctx_new_empty (void) { coro_cctx *cctx = cctx_new (); cctx->stack.sptr = 0; coro_create (&cctx->cctx, 0, 0, 0, 0); return cctx; } /* create a new cctx suitable as destination/running a perl interpreter */ static coro_cctx * cctx_new_run (void) { coro_cctx *cctx = cctx_new (); if (!coro_stack_alloc (&cctx->stack, cctx_stacksize)) { perror ("FATAL: unable to allocate stack for coroutine, exiting."); _exit (EXIT_FAILURE); } coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze); return cctx; } static void cctx_destroy (coro_cctx *cctx) { if (!cctx) return; assert (("FATAL: tried to destroy current cctx", cctx != cctx_current)); --cctx_count; coro_destroy (&cctx->cctx); coro_stack_free (&cctx->stack); Safefree (cctx); } /* wether this cctx should be destructed */ #define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE)) static coro_cctx * cctx_get (pTHX) { while (ecb_expect_true (cctx_first)) { coro_cctx *cctx = cctx_first; cctx_first = cctx->next; --cctx_idle; if (ecb_expect_true (!CCTX_EXPIRED (cctx))) return cctx; cctx_destroy (cctx); } return cctx_new_run (); } static void cctx_put (coro_cctx *cctx) { assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr)); /* free another cctx if overlimit */ if (ecb_expect_false (cctx_idle >= cctx_max_idle)) { coro_cctx *first = cctx_first; cctx_first = first->next; --cctx_idle; cctx_destroy (first); } ++cctx_idle; cctx->next = cctx_first; cctx_first = cctx; } /** coroutine switching *****************************************************/ static void transfer_check (pTHX_ struct coro *prev, struct coro *next) { /* TODO: throwing up here is considered harmful */ if (ecb_expect_true (prev != next)) { if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW)))) croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,"); if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED))) croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,"); #if !PERL_VERSION_ATLEAST (5,10,0) if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING)) croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,"); #endif } } /* always use the TRANSFER macro */ static void ecb_noinline /* noinline so we have a fixed stackframe */ transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx) { dSTACKLEVEL; /* sometimes transfer is only called to set idle_sp */ if (ecb_expect_false (!prev)) { cctx_current->idle_sp = STACKLEVEL; assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */ } else if (ecb_expect_true (prev != next)) { coro_cctx *cctx_prev; if (ecb_expect_false (prev->flags & CF_NEW)) { /* create a new empty/source context */ prev->flags &= ~CF_NEW; prev->flags |= CF_RUNNING; } prev->flags &= ~CF_RUNNING; next->flags |= CF_RUNNING; /* first get rid of the old state */ save_perl (aTHX_ prev); if (ecb_expect_false (next->flags & CF_NEW)) { /* need to start coroutine */ next->flags &= ~CF_NEW; /* setup coroutine call */ init_perl (aTHX_ next); } else load_perl (aTHX_ next); /* possibly untie and reuse the cctx */ if (ecb_expect_true ( cctx_current->idle_sp == STACKLEVEL && !(cctx_current->flags & CC_TRACE) && !force_cctx )) { /* I assume that stacklevel is a stronger indicator than PL_top_env changes */ assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te)); /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */ /* without this the next cctx_get might destroy the running cctx while still in use */ if (ecb_expect_false (CCTX_EXPIRED (cctx_current))) if (ecb_expect_true (!next->cctx)) next->cctx = cctx_get (aTHX); cctx_put (cctx_current); } else prev->cctx = cctx_current; ++next->usecount; cctx_prev = cctx_current; cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX); next->cctx = 0; if (ecb_expect_false (cctx_prev != cctx_current)) { cctx_prev->top_env = PL_top_env; PL_top_env = cctx_current->top_env; coro_transfer (&cctx_prev->cctx, &cctx_current->cctx); } transfer_tail (aTHX); } } #define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx)) #define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next) /** high level stuff ********************************************************/ /* this function is actually Coro, not Coro::State, but we call it from here */ /* because it is convenient - but it hasn't been declared yet for that reason */ static void coro_call_on_destroy (pTHX_ struct coro *coro); static void coro_state_destroy (pTHX_ struct coro *coro) { if (coro->flags & CF_ZOMBIE) return; slf_destroy (aTHX_ coro); coro->flags |= CF_ZOMBIE; if (coro->flags & CF_READY) { /* reduce nready, as destroying a ready coro effectively unreadies it */ /* alternative: look through all ready queues and remove the coro */ --coro_nready; } else coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */ if (coro->next) coro->next->prev = coro->prev; if (coro->prev) coro->prev->next = coro->next; if (coro == coro_first) coro_first = coro->next; if (coro->mainstack && coro->mainstack != main_mainstack && coro->slot && !PL_dirty) destroy_perl (aTHX_ coro); cctx_destroy (coro->cctx); SvREFCNT_dec (coro->startcv); SvREFCNT_dec (coro->args); SvREFCNT_dec (coro->swap_sv); SvREFCNT_dec (CORO_THROW); coro_call_on_destroy (aTHX_ coro); /* more destruction mayhem in coro_state_free */ } static int coro_state_free (pTHX_ SV *sv, MAGIC *mg) { struct coro *coro = (struct coro *)mg->mg_ptr; mg->mg_ptr = 0; coro_state_destroy (aTHX_ coro); SvREFCNT_dec (coro->on_destroy); SvREFCNT_dec (coro->status); Safefree (coro); return 0; } static int ecb_cold coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params) { /* called when perl clones the current process the slow way (windows process emulation) */ /* we simply nuke the pointers in the copy, causing perl to croak */ mg->mg_ptr = 0; mg->mg_virtual = 0; return 0; } static MGVTBL coro_state_vtbl = { 0, 0, 0, 0, coro_state_free, 0, #ifdef MGf_DUP coro_state_dup, #else # define MGf_DUP 0 #endif }; static void prepare_transfer (pTHX_ struct coro_transfer_args *ta, SV *prev_sv, SV *next_sv) { ta->prev = SvSTATE (prev_sv); ta->next = SvSTATE (next_sv); TRANSFER_CHECK (*ta); } static void api_transfer (pTHX_ SV *prev_sv, SV *next_sv) { struct coro_transfer_args ta; prepare_transfer (aTHX_ &ta, prev_sv, next_sv); TRANSFER (ta, 1); } /** Coro ********************************************************************/ ecb_inline void coro_enq (pTHX_ struct coro *coro) { struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN]; SvREFCNT_inc_NN (coro->hv); coro->next_ready = 0; *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro; ready [1] = coro; } ecb_inline struct coro * coro_deq (pTHX) { int prio; for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; ) { struct coro **ready = coro_ready [prio]; if (ready [0]) { struct coro *coro = ready [0]; ready [0] = coro->next_ready; return coro; } } return 0; } static void invoke_sv_ready_hook_helper (void) { dTHX; dSP; ENTER; SAVETMPS; PUSHMARK (SP); PUTBACK; call_sv (coro_readyhook, G_VOID | G_DISCARD); FREETMPS; LEAVE; } static int api_ready (pTHX_ SV *coro_sv) { struct coro *coro = SvSTATE (coro_sv); if (coro->flags & CF_READY) return 0; coro->flags |= CF_READY; coro_enq (aTHX_ coro); if (!coro_nready++) if (coroapi.readyhook) coroapi.readyhook (); return 1; } static int api_is_ready (pTHX_ SV *coro_sv) { return !!(SvSTATE (coro_sv)->flags & CF_READY); } /* expects to own a reference to next->hv */ ecb_inline void prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next) { SV *prev_sv = SvRV (coro_current); ta->prev = SvSTATE_hv (prev_sv); ta->next = next; TRANSFER_CHECK (*ta); SvRV_set (coro_current, (SV *)next->hv); free_coro_mortal (aTHX); coro_mortal = prev_sv; } static void prepare_schedule (pTHX_ struct coro_transfer_args *ta) { for (;;) { struct coro *next = coro_deq (aTHX); if (ecb_expect_true (next)) { /* cannot transfer to destroyed coros, skip and look for next */ if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED))) SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */ else { next->flags &= ~CF_READY; --coro_nready; prepare_schedule_to (aTHX_ ta, next); break; } } else { /* nothing to schedule: call the idle handler */ if (SvROK (sv_idle) && SvOBJECT (SvRV (sv_idle))) { if (SvRV (sv_idle) == SvRV (coro_current)) { require_pv ("Carp"); { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0))); PUTBACK; call_pv ("Carp::confess", G_VOID | G_DISCARD); FREETMPS; LEAVE; } } ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */ api_ready (aTHX_ SvRV (sv_idle)); --coro_nready; } else { /* TODO: deprecated, remove, cannot work reliably *//*D*/ dSP; ENTER; SAVETMPS; PUSHMARK (SP); PUTBACK; call_sv (sv_idle, G_VOID | G_DISCARD); FREETMPS; LEAVE; } } } } ecb_inline void prepare_cede (pTHX_ struct coro_transfer_args *ta) { api_ready (aTHX_ coro_current); prepare_schedule (aTHX_ ta); } ecb_inline void prepare_cede_notself (pTHX_ struct coro_transfer_args *ta) { SV *prev = SvRV (coro_current); if (coro_nready) { prepare_schedule (aTHX_ ta); api_ready (aTHX_ prev); } else prepare_nop (aTHX_ ta); } static void api_schedule (pTHX) { struct coro_transfer_args ta; prepare_schedule (aTHX_ &ta); TRANSFER (ta, 1); } static void api_schedule_to (pTHX_ SV *coro_sv) { struct coro_transfer_args ta; struct coro *next = SvSTATE (coro_sv); SvREFCNT_inc_NN (coro_sv); prepare_schedule_to (aTHX_ &ta, next); } static int api_cede (pTHX) { struct coro_transfer_args ta; prepare_cede (aTHX_ &ta); if (ecb_expect_true (ta.prev != ta.next)) { TRANSFER (ta, 1); return 1; } else return 0; } static int api_cede_notself (pTHX) { if (coro_nready) { struct coro_transfer_args ta; prepare_cede_notself (aTHX_ &ta); TRANSFER (ta, 1); return 1; } else return 0; } static void api_trace (pTHX_ SV *coro_sv, int flags) { struct coro *coro = SvSTATE (coro_sv); if (coro->flags & CF_RUNNING) croak ("cannot enable tracing on a running coroutine, caught"); if (flags & CC_TRACE) { if (!coro->cctx) coro->cctx = cctx_new_run (); else if (!(coro->cctx->flags & CC_TRACE)) croak ("cannot enable tracing on coroutine with custom stack, caught"); coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL)); } else if (coro->cctx && coro->cctx->flags & CC_TRACE) { coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL); if (coro->flags & CF_RUNNING) PL_runops = RUNOPS_DEFAULT; else coro->slot->runops = RUNOPS_DEFAULT; } } static void coro_push_av (pTHX_ AV *av, I32 gimme_v) { if (AvFILLp (av) >= 0 && gimme_v != G_VOID) { dSP; if (gimme_v == G_SCALAR) XPUSHs (AvARRAY (av)[AvFILLp (av)]); else { int i; EXTEND (SP, AvFILLp (av) + 1); for (i = 0; i <= AvFILLp (av); ++i) PUSHs (AvARRAY (av)[i]); } PUTBACK; } } static void coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb) { if (!coro->on_destroy) coro->on_destroy = newAV (); av_push (coro->on_destroy, cb); } static void slf_destroy_join (pTHX_ struct CoroSLF *frame) { SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv); } static int slf_check_join (pTHX_ struct CoroSLF *frame) { struct coro *coro = (struct coro *)frame->data; if (!coro->status) return 1; frame->destroy = 0; coro_push_av (aTHX_ coro->status, GIMME_V); SvREFCNT_dec ((SV *)coro->hv); return 0; } static void slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef); if (items > 1) croak ("join called with too many arguments"); if (coro->status) frame->prepare = prepare_nop; else { coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current))); frame->prepare = prepare_schedule; } frame->check = slf_check_join; frame->destroy = slf_destroy_join; frame->data = (void *)coro; SvREFCNT_inc (coro->hv); } static void coro_call_on_destroy (pTHX_ struct coro *coro) { AV *od = coro->on_destroy; if (!od) return; coro->on_destroy = 0; sv_2mortal ((SV *)od); while (AvFILLp (od) >= 0) { SV *cb = sv_2mortal (av_pop (od)); /* coro hv's (and only hv's at the moment) are supported as well */ if (SvSTATEhv_p (aTHX_ cb)) api_ready (aTHX_ cb); else { dSP; /* don't disturb outer sp */ PUSHMARK (SP); if (coro->status) { PUTBACK; coro_push_av (aTHX_ coro->status, G_ARRAY); SPAGAIN; } PUTBACK; call_sv (cb, G_VOID | G_DISCARD); } } } static void coro_set_status (pTHX_ struct coro *coro, SV **arg, int items) { AV *av; if (coro->status) { av = coro->status; av_clear (av); } else av = coro->status = newAV (); /* items are actually not so common, so optimise for this case */ if (items) { int i; av_extend (av, items - 1); for (i = 0; i < items; ++i) av_push (av, SvREFCNT_inc_NN (arg [i])); } } static void slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv) { av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */ api_ready (aTHX_ sv_manager); frame->prepare = prepare_schedule; frame->check = slf_check_repeat; /* as a minor optimisation, we could unwind all stacks here */ /* but that puts extra pressure on pp_slf, and is not worth much */ /*coro_unwind_stacks (aTHX);*/ } static void slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { HV *coro_hv = (HV *)SvRV (coro_current); coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items); slf_init_terminate_cancel_common (aTHX_ frame, coro_hv); } static void slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { HV *coro_hv; struct coro *coro; if (items <= 0) croak ("Coro::cancel called without coro object,"); coro = SvSTATE (arg [0]); coro_hv = coro->hv; coro_set_status (aTHX_ coro, arg + 1, items - 1); if (ecb_expect_false (coro->flags & CF_NOCANCEL)) { /* coro currently busy cancelling something, so just notify it */ coro->slf_frame.data = (void *)coro; frame->prepare = prepare_nop; frame->check = slf_check_nop; } else if (coro_hv == (HV *)SvRV (coro_current)) { /* cancelling the current coro is allowed, and equals terminate */ slf_init_terminate_cancel_common (aTHX_ frame, coro_hv); } else { struct coro *self = SvSTATE_current; if (!self) croak ("Coro::cancel called outside of thread content,"); /* otherwise we cancel directly, purely for speed reasons * unfortunately, this requires some magic trickery, as * somebody else could cancel us, so we have to fight the cancellation. * this is ugly, and hopefully fully worth the extra speed. * besides, I can't get the slow-but-safe version working... */ slf_frame.data = 0; self->flags |= CF_NOCANCEL; coro_state_destroy (aTHX_ coro); self->flags &= ~CF_NOCANCEL; if (slf_frame.data) { /* while we were busy we have been cancelled, so terminate */ slf_init_terminate_cancel_common (aTHX_ frame, self->hv); } else { frame->prepare = prepare_nop; frame->check = slf_check_nop; } } } static int slf_check_safe_cancel (pTHX_ struct CoroSLF *frame) { frame->prepare = 0; coro_unwind_stacks (aTHX); slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current)); return 1; } static int safe_cancel (pTHX_ struct coro *coro, SV **arg, int items) { if (coro->cctx) croak ("coro inside C callback, unable to cancel at this time, caught"); if (coro->flags & (CF_NEW | CF_ZOMBIE)) { coro_set_status (aTHX_ coro, arg, items); coro_state_destroy (aTHX_ coro); } else { if (!coro->slf_frame.prepare) croak ("coro outside an SLF function, unable to cancel at this time, caught"); slf_destroy (aTHX_ coro); coro_set_status (aTHX_ coro, arg, items); coro->slf_frame.prepare = prepare_nop; coro->slf_frame.check = slf_check_safe_cancel; api_ready (aTHX_ (SV *)coro->hv); } return 1; } /*****************************************************************************/ /* async pool handler */ static int slf_check_pool_handler (pTHX_ struct CoroSLF *frame) { HV *hv = (HV *)SvRV (coro_current); struct coro *coro = (struct coro *)frame->data; if (!coro->invoke_cb) return 1; /* loop till we have invoke */ else { hv_store (hv, "desc", sizeof ("desc") - 1, newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0); coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv); { dSP; XPUSHs (sv_2mortal (coro->invoke_cb)); coro->invoke_cb = 0; PUTBACK; } SvREFCNT_dec (GvAV (PL_defgv)); GvAV (PL_defgv) = coro->invoke_av; coro->invoke_av = 0; return 0; } } static void slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { HV *hv = (HV *)SvRV (coro_current); struct coro *coro = SvSTATE_hv ((SV *)hv); if (ecb_expect_true (coro->saved_deffh)) { /* subsequent iteration */ SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh; coro->saved_deffh = 0; if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss) || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size)) { slf_init_terminate_cancel_common (aTHX_ frame, hv); return; } else { av_clear (GvAV (PL_defgv)); hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0); if (ecb_expect_false (coro->swap_sv)) { SWAP_SVS_LEAVE (coro); SvREFCNT_dec_NN (coro->swap_sv); coro->swap_sv = 0; } coro->prio = 0; if (ecb_expect_false (coro->cctx) && ecb_expect_false (coro->cctx->flags & CC_TRACE)) api_trace (aTHX_ coro_current, 0); frame->prepare = prepare_schedule; av_push (av_async_pool, SvREFCNT_inc_NN (hv)); } } else { /* first iteration, simply fall through */ frame->prepare = prepare_nop; } frame->check = slf_check_pool_handler; frame->data = (void *)coro; } /*****************************************************************************/ /* rouse callback */ #define CORO_MAGIC_type_rouse PERL_MAGIC_ext static void coro_rouse_callback (pTHX_ CV *cv) { dXSARGS; SV *data = (SV *)S_GENSUB_ARG; SV *coro = SvRV (data); /* data starts being either undef or a coro, and is replaced by the results when done */ if (SvTYPE (coro) != SVt_PVAV) { /* first call, set args */ assert (&ST (0) < &ST (1)); /* ensure the stack is in the order we expect it to be */ SvRV_set (data, (SV *)av_make (items, &ST (0))); /* av_make copies the SVs */ if (coro != &PL_sv_undef) { api_ready (aTHX_ coro); SvREFCNT_dec_NN (coro); } } XSRETURN_EMPTY; } static int slf_check_rouse_wait (pTHX_ struct CoroSLF *frame) { SV *data = (SV *)frame->data; if (CORO_THROW) return 0; if (SvTYPE (SvRV (data)) != SVt_PVAV) return 1; /* now push all results on the stack */ { dSP; AV *av = (AV *)SvRV (data); int i; EXTEND (SP, AvFILLp (av) + 1); for (i = 0; i <= AvFILLp (av); ++i) PUSHs (sv_2mortal (AvARRAY (av)[i])); /* we have stolen the elements, make it unreal and free */ AvREAL_off (av); av_undef (av); PUTBACK; } return 0; } static void slf_init_rouse_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { SV *cb; if (items) cb = arg [0]; else { struct coro *coro = SvSTATE_current; if (!coro->rouse_cb) croak ("Coro::rouse_wait called without rouse callback, and no default rouse callback found either,"); cb = sv_2mortal (coro->rouse_cb); coro->rouse_cb = 0; } if (!SvROK (cb) || SvTYPE (SvRV (cb)) != SVt_PVCV || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback) croak ("Coro::rouse_wait called with illegal callback argument,"); { CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */ SV *data = (SV *)S_GENSUB_ARG; int data_ready = SvTYPE (SvRV (data)) == SVt_PVAV; /* if there is no data, we need to store the current coro in the reference so we can be woken up */ if (!data_ready) if (SvRV (data) != &PL_sv_undef) croak ("Coro::rouse_wait was called on a calback that is already being waited for - only one thread can wait for a rouse callback, caught"); else SvRV_set (data, SvREFCNT_inc_NN (SvRV (coro_current))); frame->data = (void *)data; frame->prepare = data_ready ? prepare_nop : prepare_schedule; frame->check = slf_check_rouse_wait; } } static SV * coro_new_rouse_cb (pTHX) { HV *hv = (HV *)SvRV (coro_current); struct coro *coro = SvSTATE_hv (hv); SV *data = newRV_noinc (&PL_sv_undef); SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data); sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0); SvREFCNT_dec_NN (data); /* magicext increases the refcount */ SvREFCNT_dec (coro->rouse_cb); coro->rouse_cb = SvREFCNT_inc_NN (cb); return cb; } /*****************************************************************************/ /* schedule-like-function opcode (SLF) */ static UNOP slf_restore; /* restore stack as entersub did, for first-re-run */ static const CV *slf_cv; static SV **slf_argv; static int slf_argc, slf_arga; /* count, allocated */ static I32 slf_ax; /* top of stack, for restore */ /* this restores the stack in the case we patched the entersub, to */ /* recreate the stack frame as perl will on following calls */ /* since entersub cleared the stack */ static OP * pp_restore (pTHX) { int i; SV **SP = PL_stack_base + slf_ax; PUSHMARK (SP); EXTEND (SP, slf_argc + 1); for (i = 0; i < slf_argc; ++i) PUSHs (sv_2mortal (slf_argv [i])); PUSHs ((SV *)CvGV (slf_cv)); RETURNOP (slf_restore.op_first); } static void slf_prepare_transfer (pTHX_ struct coro_transfer_args *ta) { SV **arg = (SV **)slf_frame.data; prepare_transfer (aTHX_ ta, arg [0], arg [1]); } static void slf_init_transfer (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { if (items != 2) croak ("Coro::State::transfer (prev, next) expects two arguments, not %d,", items); frame->prepare = slf_prepare_transfer; frame->check = slf_check_nop; frame->data = (void *)arg; /* let's hope it will stay valid */ } static void slf_init_schedule (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { frame->prepare = prepare_schedule; frame->check = slf_check_nop; } static void slf_prepare_schedule_to (pTHX_ struct coro_transfer_args *ta) { struct coro *next = (struct coro *)slf_frame.data; SvREFCNT_inc_NN (next->hv); prepare_schedule_to (aTHX_ ta, next); } static void slf_init_schedule_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { if (!items) croak ("Coro::schedule_to expects a coroutine argument, caught"); frame->data = (void *)SvSTATE (arg [0]); frame->prepare = slf_prepare_schedule_to; frame->check = slf_check_nop; } static void slf_init_cede_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { api_ready (aTHX_ SvRV (coro_current)); slf_init_schedule_to (aTHX_ frame, cv, arg, items); } static void slf_init_cede (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { frame->prepare = prepare_cede; frame->check = slf_check_nop; } static void slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { frame->prepare = prepare_cede_notself; frame->check = slf_check_nop; } /* "undo"/cancel a running slf call - used when cancelling a coro, mainly */ static void slf_destroy (pTHX_ struct coro *coro) { struct CoroSLF frame = coro->slf_frame; /* * The on_destroy below most likely is from an SLF call. * Since by definition the SLF call will not finish when we destroy * the coro, we will have to force-finish it here, otherwise * cleanup functions cannot call SLF functions. */ coro->slf_frame.prepare = 0; /* this callback is reserved for slf functions needing to do cleanup */ if (frame.destroy && frame.prepare && !PL_dirty) frame.destroy (aTHX_ &frame); } /* * these not obviously related functions are all rolled into one * function to increase chances that they all will call transfer with the same * stack offset * SLF stands for "schedule-like-function". */ static OP * pp_slf (pTHX) { I32 checkmark; /* mark SP to see how many elements check has pushed */ /* set up the slf frame, unless it has already been set-up */ /* the latter happens when a new coro has been started */ /* or when a new cctx was attached to an existing coroutine */ if (ecb_expect_true (!slf_frame.prepare)) { /* first iteration */ dSP; SV **arg = PL_stack_base + TOPMARK + 1; int items = SP - arg; /* args without function object */ SV *gv = *sp; /* do a quick consistency check on the "function" object, and if it isn't */ /* for us, divert to the real entersub */ if (SvTYPE (gv) != SVt_PVGV || !GvCV (gv) || !(CvFLAGS (GvCV (gv)) & CVf_SLF)) return PL_ppaddr[OP_ENTERSUB](aTHX); if (!(PL_op->op_flags & OPf_STACKED)) { /* ampersand-form of call, use @_ instead of stack */ AV *av = GvAV (PL_defgv); arg = AvARRAY (av); items = AvFILLp (av) + 1; } /* now call the init function, which needs to set up slf_frame */ ((coro_slf_cb)CvXSUBANY (GvCV (gv)).any_ptr) (aTHX_ &slf_frame, GvCV (gv), arg, items); /* pop args */ SP = PL_stack_base + POPMARK; PUTBACK; } /* now that we have a slf_frame, interpret it! */ /* we use a callback system not to make the code needlessly */ /* complicated, but so we can run multiple perl coros from one cctx */ do { struct coro_transfer_args ta; slf_frame.prepare (aTHX_ &ta); TRANSFER (ta, 0); checkmark = PL_stack_sp - PL_stack_base; } while (slf_frame.check (aTHX_ &slf_frame)); slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */ /* exception handling */ if (ecb_expect_false (CORO_THROW)) { SV *exception = sv_2mortal (CORO_THROW); CORO_THROW = 0; sv_setsv (ERRSV, exception); croak (0); } /* return value handling - mostly like entersub */ /* make sure we put something on the stack in scalar context */ if (GIMME_V == G_SCALAR && ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1)) { dSP; SV **bot = PL_stack_base + checkmark; if (sp == bot) /* too few, push undef */ bot [1] = &PL_sv_undef; else /* too many, take last one */ bot [1] = *sp; SP = bot + 1; PUTBACK; } return NORMAL; } static void api_execute_slf (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax) { int i; SV **arg = PL_stack_base + ax; int items = PL_stack_sp - arg + 1; assert (("FATAL: SLF call with illegal CV value", !CvANON (cv))); if (PL_op->op_ppaddr != PL_ppaddr [OP_ENTERSUB] && PL_op->op_ppaddr != pp_slf) croak ("FATAL: Coro SLF calls can only be made normally, not via goto or any other means, caught"); CvFLAGS (cv) |= CVf_SLF; CvXSUBANY (cv).any_ptr = (void *)init_cb; slf_cv = cv; /* we patch the op, and then re-run the whole call */ /* we have to put the same argument on the stack for this to work */ /* and this will be done by pp_restore */ slf_restore.op_next = (OP *)&slf_restore; slf_restore.op_type = OP_CUSTOM; slf_restore.op_ppaddr = pp_restore; slf_restore.op_first = PL_op; slf_ax = ax - 1; /* undo the ax++ inside dAXMARK */ if (PL_op->op_flags & OPf_STACKED) { if (items > slf_arga) { slf_arga = items; Safefree (slf_argv); New (0, slf_argv, slf_arga, SV *); } slf_argc = items; for (i = 0; i < items; ++i) slf_argv [i] = SvREFCNT_inc (arg [i]); } else slf_argc = 0; PL_op->op_ppaddr = pp_slf; /*PL_op->op_type = OP_CUSTOM; /* we do behave like entersub still */ PL_op = (OP *)&slf_restore; } /*****************************************************************************/ /* dynamic wind */ static void on_enterleave_call (pTHX_ SV *cb) { dSP; PUSHSTACK; PUSHMARK (SP); PUTBACK; call_sv (cb, G_VOID | G_DISCARD); SPAGAIN; POPSTACK; } static SV * coro_avp_pop_and_free (pTHX_ AV **avp) { AV *av = *avp; SV *res = av_pop (av); if (AvFILLp (av) < 0) { *avp = 0; SvREFCNT_dec (av); } return res; } static void coro_pop_on_enter (pTHX_ void *coro) { SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_enter); SvREFCNT_dec (cb); } static void coro_pop_on_leave (pTHX_ void *coro) { SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave); on_enterleave_call (aTHX_ sv_2mortal (cb)); } static void enterleave_hook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, void *arg) { if (!hook) return; if (!*avp) { *avp = newAV (); AvREAL_off (*avp); } av_push (*avp, (SV *)hook); av_push (*avp, (SV *)arg); } static void enterleave_unhook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, int execute) { AV *av = *avp; int i; if (!av) return; for (i = AvFILLp (av) - 1; i >= 0; i -= 2) if (AvARRAY (av)[i] == (SV *)hook) { if (execute) hook (aTHX_ (void *)AvARRAY (av)[i + 1]); memmove (AvARRAY (av) + i, AvARRAY (av) + i + 2, AvFILLp (av) - i - 1); av_pop (av); av_pop (av); break; } if (AvFILLp (av) >= 0) { *avp = 0; SvREFCNT_dec_NN (av); } } static void api_enterleave_hook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg) { struct coro *coro = SvSTATE (coro_sv); if (SvSTATE_current == coro) if (enter) enter (aTHX_ enter_arg); enterleave_hook_xs (aTHX_ coro, &coro->on_enter_xs, enter, enter_arg); enterleave_hook_xs (aTHX_ coro, &coro->on_leave_xs, leave, leave_arg); } static void api_enterleave_unhook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave) { struct coro *coro = SvSTATE (coro_sv); enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0); enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, SvSTATE_current == coro); } static void savedestructor_unhook_enter (pTHX_ coro_enterleave_hook enter) { struct coro *coro = SvSTATE_current; enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0); } static void savedestructor_unhook_leave (pTHX_ coro_enterleave_hook leave) { struct coro *coro = SvSTATE_current; enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, 1); } static void api_enterleave_scope_hook (pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg) { api_enterleave_hook (aTHX_ coro_current, enter, enter_arg, leave, leave_arg); /* this ought to be much cheaper than malloc + a single destructor call */ if (enter) SAVEDESTRUCTOR_X (savedestructor_unhook_enter, enter); if (leave) SAVEDESTRUCTOR_X (savedestructor_unhook_leave, leave); } /*****************************************************************************/ /* PerlIO::cede */ typedef struct { PerlIOBuf base; NV next, every; } PerlIOCede; static IV ecb_cold PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { PerlIOCede *self = PerlIOSelf (f, PerlIOCede); self->every = SvCUR (arg) ? SvNV (arg) : 0.01; self->next = nvtime () + self->every; return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab); } static SV * ecb_cold PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { PerlIOCede *self = PerlIOSelf (f, PerlIOCede); return newSVnv (self->every); } static IV PerlIOCede_flush (pTHX_ PerlIO *f) { PerlIOCede *self = PerlIOSelf (f, PerlIOCede); double now = nvtime (); if (now >= self->next) { api_cede (aTHX); self->next = now + self->every; } return PerlIOBuf_flush (aTHX_ f); } static PerlIO_funcs PerlIO_cede = { sizeof(PerlIO_funcs), "cede", sizeof(PerlIOCede), PERLIO_K_DESTRUCT | PERLIO_K_RAW, PerlIOCede_pushed, PerlIOBuf_popped, PerlIOBuf_open, PerlIOBase_binmode, PerlIOCede_getarg, PerlIOBase_fileno, PerlIOBuf_dup, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, PerlIOBuf_seek, PerlIOBuf_tell, PerlIOBuf_close, PerlIOCede_flush, PerlIOBuf_fill, PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, PerlIOBuf_get_cnt, PerlIOBuf_set_ptrcnt, }; /*****************************************************************************/ /* Coro::Semaphore & Coro::Signal */ static SV * coro_waitarray_new (pTHX_ int count) { /* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */ AV *av = newAV (); SV **ary; /* unfortunately, building manually saves memory */ Newx (ary, 2, SV *); AvALLOC (av) = ary; #if PERL_VERSION_ATLEAST (5,10,0) AvARRAY (av) = ary; #else /* 5.8.8 needs this syntax instead of AvARRAY = ary, yet */ /* -DDEBUGGING flags this as a bug, despite it perfectly working */ SvPVX ((SV *)av) = (char *)ary; #endif AvMAX (av) = 1; AvFILLp (av) = 0; ary [0] = newSViv (count); return newRV_noinc ((SV *)av); } /* semaphore */ static void coro_semaphore_adjust (pTHX_ AV *av, IV adjust) { SV *count_sv = AvARRAY (av)[0]; IV count = SvIVX (count_sv); count += adjust; SvIVX (count_sv) = count; /* now wake up as many waiters as are expected to lock */ while (count > 0 && AvFILLp (av) > 0) { SV *cb; /* swap first two elements so we can shift a waiter */ AvARRAY (av)[0] = AvARRAY (av)[1]; AvARRAY (av)[1] = count_sv; cb = av_shift (av); if (SvOBJECT (cb)) { api_ready (aTHX_ cb); --count; } else if (SvTYPE (cb) == SVt_PVCV) { dSP; PUSHMARK (SP); XPUSHs (sv_2mortal (newRV_inc ((SV *)av))); PUTBACK; call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR); } SvREFCNT_dec_NN (cb); } } static void coro_semaphore_destroy (pTHX_ struct CoroSLF *frame) { /* call $sem->adjust (0) to possibly wake up some other waiters */ coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0); } static int slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire) { AV *av = (AV *)frame->data; SV *count_sv = AvARRAY (av)[0]; SV *coro_hv = SvRV (coro_current); frame->destroy = 0; /* if we are about to throw, don't actually acquire the lock, just throw */ if (ecb_expect_false (CORO_THROW)) { /* we still might be responsible for the semaphore, so wake up others */ coro_semaphore_adjust (aTHX_ av, 0); return 0; } else if (SvIVX (count_sv) > 0) { if (acquire) SvIVX (count_sv) = SvIVX (count_sv) - 1; else coro_semaphore_adjust (aTHX_ av, 0); return 0; } else { int i; /* if we were woken up but can't down, we look through the whole */ /* waiters list and only add us if we aren't in there already */ /* this avoids some degenerate memory usage cases */ for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */ if (AvARRAY (av)[i] == coro_hv) return 1; av_push (av, SvREFCNT_inc (coro_hv)); return 1; } } static int slf_check_semaphore_down (pTHX_ struct CoroSLF *frame) { return slf_check_semaphore_down_or_wait (aTHX_ frame, 1); } static int slf_check_semaphore_wait (pTHX_ struct CoroSLF *frame) { return slf_check_semaphore_down_or_wait (aTHX_ frame, 0); } static void slf_init_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { AV *av = (AV *)SvRV (arg [0]); if (SvIVX (AvARRAY (av)[0]) > 0) { frame->data = (void *)av; frame->prepare = prepare_nop; } else { av_push (av, SvREFCNT_inc (SvRV (coro_current))); frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av)); frame->prepare = prepare_schedule; /* to avoid race conditions when a woken-up coro gets terminated */ /* we arrange for a temporary on_destroy that calls adjust (0) */ frame->destroy = coro_semaphore_destroy; } } static void slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items); frame->check = slf_check_semaphore_down; } static void slf_init_semaphore_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { if (items >= 2) { /* callback form */ AV *av = (AV *)SvRV (arg [0]); SV *cb_cv = s_get_cv_croak (arg [1]); av_push (av, SvREFCNT_inc_NN (cb_cv)); if (SvIVX (AvARRAY (av)[0]) > 0) coro_semaphore_adjust (aTHX_ av, 0); frame->prepare = prepare_nop; frame->check = slf_check_nop; } else { slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items); frame->check = slf_check_semaphore_wait; } } /* signal */ static void coro_signal_wake (pTHX_ AV *av, int count) { SvIVX (AvARRAY (av)[0]) = 0; /* now signal count waiters */ while (count > 0 && AvFILLp (av) > 0) { SV *cb; /* swap first two elements so we can shift a waiter */ cb = AvARRAY (av)[0]; AvARRAY (av)[0] = AvARRAY (av)[1]; AvARRAY (av)[1] = cb; cb = av_shift (av); if (SvTYPE (cb) == SVt_PVCV) { dSP; PUSHMARK (SP); XPUSHs (sv_2mortal (newRV_inc ((SV *)av))); PUTBACK; call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR); } else { api_ready (aTHX_ cb); sv_setiv (cb, 0); /* signal waiter */ } SvREFCNT_dec_NN (cb); --count; } } static int slf_check_signal_wait (pTHX_ struct CoroSLF *frame) { /* if we are about to throw, also stop waiting */ return SvROK ((SV *)frame->data) && !CORO_THROW; } static void slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { AV *av = (AV *)SvRV (arg [0]); if (items >= 2) { SV *cb_cv = s_get_cv_croak (arg [1]); av_push (av, SvREFCNT_inc_NN (cb_cv)); if (SvIVX (AvARRAY (av)[0])) coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */ frame->prepare = prepare_nop; frame->check = slf_check_nop; } else if (SvIVX (AvARRAY (av)[0])) { SvIVX (AvARRAY (av)[0]) = 0; frame->prepare = prepare_nop; frame->check = slf_check_nop; } else { SV *waiter = newSVsv (coro_current); /* owned by signal av */ av_push (av, waiter); frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */ frame->prepare = prepare_schedule; frame->check = slf_check_signal_wait; } } /*****************************************************************************/ /* Coro::AIO */ #define CORO_MAGIC_type_aio PERL_MAGIC_ext /* helper storage struct */ struct io_state { int errorno; I32 laststype; /* U16 in 5.10.0 */ int laststatval; Stat_t statcache; }; static void coro_aio_callback (pTHX_ CV *cv) { dXSARGS; AV *state = (AV *)S_GENSUB_ARG; SV *coro = av_pop (state); SV *data_sv = newSV (sizeof (struct io_state)); av_extend (state, items - 1); sv_upgrade (data_sv, SVt_PV); SvCUR_set (data_sv, sizeof (struct io_state)); SvPOK_only (data_sv); { struct io_state *data = (struct io_state *)SvPVX (data_sv); data->errorno = errno; data->laststype = PL_laststype; data->laststatval = PL_laststatval; data->statcache = PL_statcache; } /* now build the result vector out of all the parameters and the data_sv */ { int i; for (i = 0; i < items; ++i) av_push (state, SvREFCNT_inc_NN (ST (i))); } av_push (state, data_sv); api_ready (aTHX_ coro); SvREFCNT_dec_NN (coro); SvREFCNT_dec_NN ((AV *)state); } static int slf_check_aio_req (pTHX_ struct CoroSLF *frame) { AV *state = (AV *)frame->data; /* if we are about to throw, return early */ /* this does not cancel the aio request, but at least */ /* it quickly returns */ if (CORO_THROW) return 0; /* one element that is an RV? repeat! */ if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV) return 1; /* restore status */ { SV *data_sv = av_pop (state); struct io_state *data = (struct io_state *)SvPVX (data_sv); errno = data->errorno; PL_laststype = data->laststype; PL_laststatval = data->laststatval; PL_statcache = data->statcache; SvREFCNT_dec_NN (data_sv); } /* push result values */ { dSP; int i; EXTEND (SP, AvFILLp (state) + 1); for (i = 0; i <= AvFILLp (state); ++i) PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (state)[i]))); PUTBACK; } return 0; } static void slf_init_aio_req (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items) { AV *state = (AV *)sv_2mortal ((SV *)newAV ()); SV *coro_hv = SvRV (coro_current); struct coro *coro = SvSTATE_hv (coro_hv); /* put our coroutine id on the state arg */ av_push (state, SvREFCNT_inc_NN (coro_hv)); /* first see whether we have a non-zero priority and set it as AIO prio */ if (coro->prio) { dSP; static SV *prio_cv; static SV *prio_sv; if (ecb_expect_false (!prio_cv)) { prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0); prio_sv = newSViv (0); } PUSHMARK (SP); sv_setiv (prio_sv, coro->prio); XPUSHs (prio_sv); PUTBACK; call_sv (prio_cv, G_VOID | G_DISCARD); } /* now call the original request */ { dSP; CV *req = (CV *)CORO_MAGIC_NN ((SV *)cv, CORO_MAGIC_type_aio)->mg_obj; int i; PUSHMARK (SP); /* first push all args to the stack */ EXTEND (SP, items + 1); for (i = 0; i < items; ++i) PUSHs (arg [i]); /* now push the callback closure */ PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state)))); /* now call the AIO function - we assume our request is uncancelable */ PUTBACK; call_sv ((SV *)req, G_VOID | G_DISCARD); } /* now that the request is going, we loop till we have a result */ frame->data = (void *)state; frame->prepare = prepare_schedule; frame->check = slf_check_aio_req; } static void coro_aio_req_xs (pTHX_ CV *cv) { dXSARGS; CORO_EXECUTE_SLF_XS (slf_init_aio_req); XSRETURN_EMPTY; } /*****************************************************************************/ #if CORO_CLONE # include "clone.c" #endif /*****************************************************************************/ static SV * coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro) { SV *coro_sv; struct coro *coro; MAGIC *mg; HV *hv; SV *cb; int i; if (argc > 0) { cb = s_get_cv_croak (argv [0]); if (!is_coro) { if (CvISXSUB (cb)) croak ("Coro::State doesn't support XS functions as coroutine start, caught"); if (!CvROOT (cb)) croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught"); } } Newz (0, coro, 1, struct coro); coro->args = newAV (); coro->flags = CF_NEW; if (coro_first) coro_first->prev = coro; coro->next = coro_first; coro_first = coro; coro->hv = hv = newHV (); mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0); mg->mg_flags |= MGf_DUP; coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash); if (argc > 0) { av_extend (coro->args, argc + is_coro - 1); if (is_coro) { av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb)); cb = (SV *)cv_coro_run; } coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb); for (i = 1; i < argc; i++) av_push (coro->args, newSVsv (argv [i])); } return coro_sv; } #ifndef __cplusplus ecb_cold XS(boot_Coro__State); #endif #if CORO_JIT static void ecb_noinline ecb_cold pushav_4uv (pTHX_ UV a, UV b, UV c, UV d) { dSP; AV *av = newAV (); av_store (av, 3, newSVuv (d)); av_store (av, 2, newSVuv (c)); av_store (av, 1, newSVuv (b)); av_store (av, 0, newSVuv (a)); XPUSHs (sv_2mortal (newRV_noinc ((SV *)av))); PUTBACK; } static void ecb_noinline ecb_cold jit_init (pTHX) { dSP; SV *load, *save; char *map_base; char *load_ptr, *save_ptr; STRLEN load_len, save_len, map_len; int count; eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1); PUSHMARK (SP); #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type)); #include "state.h" count = call_pv ("Coro::State::_jit", G_ARRAY); SPAGAIN; save = POPs; save_ptr = SvPVbyte (save, save_len); load = POPs; load_ptr = SvPVbyte (load, load_len); map_len = load_len + save_len + 16; map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); if (map_base == (char *)MAP_FAILED) map_base = mmap (0, map_len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED)); load_perl_slots = (load_save_perl_slots_type)map_base; memcpy (map_base, load_ptr, load_len); map_base += (load_len + 15) & ~15; save_perl_slots = (load_save_perl_slots_type)map_base; memcpy (map_base, save_ptr, save_len); /* we are good citizens and try to make the page read-only, so the evil evil */ /* hackers might have it a bit more difficult */ mprotect (map_base, map_len, PROT_READ | PROT_EXEC); PUTBACK; eval_pv ("undef &Coro::State::_jit", 1); } #endif MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_ PROTOTYPES: DISABLE BOOT: { #define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl."); #include "state.h" #ifdef USE_ITHREADS # if CORO_PTHREAD coro_thx = PERL_GET_CONTEXT; # endif #endif /* perl defines these to check for existance first, but why it doesn't */ /* just create them one at init time is not clear to me, except for */ /* programs trying to delete them, but... */ /* anyway, we declare this as invalid and make sure they are initialised here */ DEFSV; ERRSV; cctx_current = cctx_new_empty (); irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV); stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); { /* * we provide a vtbvl for %SIG magic that replaces PL_vtbl_sig * by coro_sig_vtbl in hash values. */ MAGIC *mg = mg_find ((SV *)GvHV (gv_fetchpv ("SIG", GV_ADD | GV_NOTQUAL, SVt_PVHV)), PERL_MAGIC_sig); /* this only works if perl doesn't have a vtbl for %SIG */ assert (!mg->mg_virtual); /* * The irony is that the perl API itself asserts that mg_virtual * must be non-const, yet perl5porters insisted on marking their * vtbls as read-only, just to thwart perl modules from patching * them. */ mg->mg_virtual = (MGVTBL *)&coro_sig_vtbl; mg->mg_flags |= MGf_COPY; coro_sigelem_vtbl = PL_vtbl_sigelem; coro_sigelem_vtbl.svt_get = coro_sigelem_get; coro_sigelem_vtbl.svt_set = coro_sigelem_set; coro_sigelem_vtbl.svt_clear = coro_sigelem_clr; } rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV)); rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV)); coro_state_stash = gv_stashpv ("Coro::State", TRUE); newCONSTSUB (coro_state_stash, "BACKEND", newSVpv (CORO_BACKEND, 0)); /* undocumented */ newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE)); newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB)); newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE)); newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL)); main_mainstack = PL_mainstack; main_top_env = PL_top_env; while (main_top_env->je_prev) main_top_env = main_top_env->je_prev; { SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf))); if (!PL_custom_op_names) PL_custom_op_names = newHV (); hv_store_ent (PL_custom_op_names, slf, newSVpv ("coro_slf", 0), 0); if (!PL_custom_op_descs) PL_custom_op_descs = newHV (); hv_store_ent (PL_custom_op_descs, slf, newSVpv ("coro schedule like function", 0), 0); } coroapi.ver = CORO_API_VERSION; coroapi.rev = CORO_API_REVISION; coroapi.transfer = api_transfer; coroapi.sv_state = SvSTATE_; coroapi.execute_slf = api_execute_slf; coroapi.prepare_nop = prepare_nop; coroapi.prepare_schedule = prepare_schedule; coroapi.prepare_cede = prepare_cede; coroapi.prepare_cede_notself = prepare_cede_notself; time_init (aTHX); assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL)); #if CORO_JIT PUTBACK; jit_init (aTHX); SPAGAIN; #endif } SV * new (SV *klass, ...) ALIAS: Coro::new = 1 CODE: RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix); OUTPUT: RETVAL void transfer (...) PROTOTYPE: $$ CODE: CORO_EXECUTE_SLF_XS (slf_init_transfer); SV * clone (Coro::State coro) CODE: { #if CORO_CLONE struct coro *ncoro = coro_clone (aTHX_ coro); MAGIC *mg; /* TODO: too much duplication */ ncoro->hv = newHV (); mg = sv_magicext ((SV *)ncoro->hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)ncoro, 0); mg->mg_flags |= MGf_DUP; RETVAL = sv_bless (newRV_noinc ((SV *)ncoro->hv), SvSTASH (coro->hv)); #else croak ("Coro::State->clone has not been configured into this installation of Coro, realised"); #endif } OUTPUT: RETVAL int cctx_stacksize (int new_stacksize = 0) PROTOTYPE: ;$ CODE: RETVAL = cctx_stacksize; if (new_stacksize) { cctx_stacksize = new_stacksize; ++cctx_gen; } OUTPUT: RETVAL int cctx_max_idle (int max_idle = 0) PROTOTYPE: ;$ CODE: RETVAL = cctx_max_idle; if (max_idle > 1) cctx_max_idle = max_idle; OUTPUT: RETVAL int cctx_count () PROTOTYPE: CODE: RETVAL = cctx_count; OUTPUT: RETVAL int cctx_idle () PROTOTYPE: CODE: RETVAL = cctx_idle; OUTPUT: RETVAL void list () PROTOTYPE: PPCODE: { struct coro *coro; for (coro = coro_first; coro; coro = coro->next) if (coro->hv) XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv))); } void call (Coro::State coro, SV *coderef) ALIAS: eval = 1 CODE: { struct coro *current = SvSTATE_current; if ((coro == current) || (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))) { struct CoroSLF slf_save; if (current != coro) { PUTBACK; save_perl (aTHX_ current); load_perl (aTHX_ coro); /* the coro is most likely in an active SLF call. * while not strictly required (the code we execute is * not allowed to call any SLF functions), it's cleaner * to reinitialise the slf_frame and restore it later. * This might one day allow us to actually do SLF calls * from code executed here. */ slf_save = slf_frame; slf_frame.prepare = 0; SPAGAIN; } PUSHSTACK; PUSHMARK (SP); PUTBACK; if (ix) eval_sv (coderef, 0); else call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); POPSTACK; SPAGAIN; if (current != coro) { PUTBACK; slf_frame = slf_save; save_perl (aTHX_ coro); load_perl (aTHX_ current); SPAGAIN; } } } SV * is_ready (Coro::State coro) PROTOTYPE: $ ALIAS: is_ready = CF_READY is_running = CF_RUNNING is_new = CF_NEW is_destroyed = CF_ZOMBIE is_zombie = CF_ZOMBIE is_suspended = CF_SUSPENDED CODE: RETVAL = boolSV (coro->flags & ix); OUTPUT: RETVAL void throw (SV *self, SV *exception = &PL_sv_undef) PROTOTYPE: $;$ CODE: { struct coro *coro = SvSTATE (self); struct coro *current = SvSTATE_current; SV **exceptionp = coro == current ? &CORO_THROW : &coro->except; SvREFCNT_dec (*exceptionp); SvGETMAGIC (exception); *exceptionp = SvOK (exception) ? newSVsv (exception) : 0; api_ready (aTHX_ self); } void api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB) PROTOTYPE: $;$ C_ARGS: aTHX_ coro, flags SV * has_cctx (Coro::State coro) PROTOTYPE: $ CODE: /* maybe manage the running flag differently */ RETVAL = boolSV (!!coro->cctx || (coro->flags & CF_RUNNING)); OUTPUT: RETVAL int is_traced (Coro::State coro) PROTOTYPE: $ CODE: RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL; OUTPUT: RETVAL UV rss (Coro::State coro) PROTOTYPE: $ ALIAS: usecount = 1 CODE: switch (ix) { case 0: RETVAL = coro_rss (aTHX_ coro); break; case 1: RETVAL = coro->usecount; break; } OUTPUT: RETVAL void force_cctx () PROTOTYPE: CODE: cctx_current->idle_sp = 0; void swap_defsv (Coro::State self) PROTOTYPE: $ ALIAS: swap_defav = 1 CODE: if (!self->slot) croak ("cannot swap state with coroutine that has no saved state,"); else { SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv); SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv; SV *tmp = *src; *src = *dst; *dst = tmp; } void cancel (Coro::State self) CODE: coro_state_destroy (aTHX_ self); SV * enable_times (int enabled = enable_times) CODE: { RETVAL = boolSV (enable_times); if (enabled != enable_times) { enable_times = enabled; coro_times_update (); (enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current)); } } OUTPUT: RETVAL void times (Coro::State self) PPCODE: { struct coro *current = SvSTATE (coro_current); if (ecb_expect_false (current == self)) { coro_times_update (); coro_times_add (SvSTATE (coro_current)); } EXTEND (SP, 2); PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9))); PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9))); if (ecb_expect_false (current == self)) coro_times_sub (SvSTATE (coro_current)); } void swap_sv (Coro::State coro, SV *sva, SV *svb) CODE: { struct coro *current = SvSTATE_current; AV *swap_sv; int i; sva = SvRV (sva); svb = SvRV (svb); if (current == coro) SWAP_SVS_LEAVE (current); if (!coro->swap_sv) coro->swap_sv = newAV (); swap_sv = coro->swap_sv; for (i = AvFILLp (swap_sv) - 1; i >= 0; i -= 2) { SV *a = AvARRAY (swap_sv)[i ]; SV *b = AvARRAY (swap_sv)[i + 1]; if (a == sva && b == svb) { SvREFCNT_dec_NN (a); SvREFCNT_dec_NN (b); for (; i <= AvFILLp (swap_sv) - 2; i++) AvARRAY (swap_sv)[i] = AvARRAY (swap_sv)[i + 2]; AvFILLp (swap_sv) -= 2; goto removed; } } av_push (swap_sv, SvREFCNT_inc_NN (sva)); av_push (swap_sv, SvREFCNT_inc_NN (svb)); removed: if (current == coro) SWAP_SVS_ENTER (current); } MODULE = Coro::State PACKAGE = Coro BOOT: { if (SVt_LAST > 32) croak ("Coro internal error: SVt_LAST > 32, swap_sv might need adjustment"); sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE); sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE); cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD); coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current); av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE); av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE); sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE); sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE); sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle); sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro); cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler); CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */ coro_stash = gv_stashpv ("Coro", TRUE); newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX)); newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH)); newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL)); newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW)); newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE)); newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN)); { SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE); coroapi.schedule = api_schedule; coroapi.schedule_to = api_schedule_to; coroapi.cede = api_cede; coroapi.cede_notself = api_cede_notself; coroapi.ready = api_ready; coroapi.is_ready = api_is_ready; coroapi.nready = coro_nready; coroapi.current = coro_current; coroapi.enterleave_hook = api_enterleave_hook; coroapi.enterleave_unhook = api_enterleave_unhook; coroapi.enterleave_scope_hook = api_enterleave_scope_hook; /*GCoroAPI = &coroapi;*/ sv_setiv (sv, PTR2IV (&coroapi)); SvREADONLY_on (sv); } } SV * async (...) PROTOTYPE: &@ CODE: RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1); api_ready (aTHX_ RETVAL); OUTPUT: RETVAL void _destroy (Coro::State coro) CODE: /* used by the manager thread */ coro_state_destroy (aTHX_ coro); void on_destroy (Coro::State coro, SV *cb) CODE: coro_push_on_destroy (aTHX_ coro, newSVsv (cb)); void join (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_join); void terminate (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_terminate); void cancel (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_cancel); int safe_cancel (Coro::State self, ...) C_ARGS: aTHX_ self, &ST (1), items - 1 void schedule (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_schedule); void schedule_to (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_schedule_to); void cede_to (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_cede_to); void cede (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_cede); void cede_notself (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_cede_notself); void _set_current (SV *current) PROTOTYPE: $ CODE: SvREFCNT_dec_NN (SvRV (coro_current)); SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current))); void _set_readyhook (SV *hook) PROTOTYPE: $ CODE: SvREFCNT_dec (coro_readyhook); SvGETMAGIC (hook); if (SvOK (hook)) { coro_readyhook = newSVsv (hook); CORO_READYHOOK = invoke_sv_ready_hook_helper; } else { coro_readyhook = 0; CORO_READYHOOK = 0; } int prio (Coro::State coro, int newprio = 0) PROTOTYPE: $;$ ALIAS: nice = 1 CODE: { RETVAL = coro->prio; if (items > 1) { if (ix) newprio = coro->prio - newprio; if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN; if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX; coro->prio = newprio; } } OUTPUT: RETVAL SV * ready (SV *self) PROTOTYPE: $ CODE: RETVAL = boolSV (api_ready (aTHX_ self)); OUTPUT: RETVAL int nready (...) PROTOTYPE: CODE: RETVAL = coro_nready; OUTPUT: RETVAL void suspend (Coro::State self) PROTOTYPE: $ CODE: self->flags |= CF_SUSPENDED; void resume (Coro::State self) PROTOTYPE: $ CODE: self->flags &= ~CF_SUSPENDED; void _pool_handler (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_pool_handler); void async_pool (SV *cv, ...) PROTOTYPE: &@ PPCODE: { HV *hv = (HV *)av_pop (av_async_pool); AV *av = newAV (); SV *cb = ST (0); int i; av_extend (av, items - 2); for (i = 1; i < items; ++i) av_push (av, SvREFCNT_inc_NN (ST (i))); if ((SV *)hv == &PL_sv_undef) { SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1); hv = (HV *)SvREFCNT_inc_NN (SvRV (sv)); SvREFCNT_dec_NN (sv); } { struct coro *coro = SvSTATE_hv (hv); assert (!coro->invoke_cb); assert (!coro->invoke_av); coro->invoke_cb = SvREFCNT_inc (cb); coro->invoke_av = av; } api_ready (aTHX_ (SV *)hv); if (GIMME_V != G_VOID) XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv))); else SvREFCNT_dec_NN (hv); } SV * rouse_cb () PROTOTYPE: CODE: RETVAL = coro_new_rouse_cb (aTHX); OUTPUT: RETVAL void rouse_wait (...) PROTOTYPE: ;$ PPCODE: CORO_EXECUTE_SLF_XS (slf_init_rouse_wait); void on_enter (SV *block) ALIAS: on_leave = 1 PROTOTYPE: & CODE: { struct coro *coro = SvSTATE_current; AV **avp = ix ? &coro->on_leave : &coro->on_enter; block = s_get_cv_croak (block); if (!*avp) *avp = newAV (); av_push (*avp, SvREFCNT_inc (block)); if (!ix) on_enterleave_call (aTHX_ block); LEAVE; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */ SAVEDESTRUCTOR_X (ix ? coro_pop_on_leave : coro_pop_on_enter, (void *)coro); ENTER; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */ } MODULE = Coro::State PACKAGE = PerlIO::cede BOOT: PerlIO_define_layer (aTHX_ &PerlIO_cede); MODULE = Coro::State PACKAGE = Coro::Semaphore SV * new (SV *klass, SV *count = 0) CODE: { int semcnt = 1; if (count) { SvGETMAGIC (count); if (SvOK (count)) semcnt = SvIV (count); } RETVAL = sv_bless ( coro_waitarray_new (aTHX_ semcnt), GvSTASH (CvGV (cv)) ); } OUTPUT: RETVAL # helper for Coro::Channel and others SV * _alloc (int count) CODE: RETVAL = coro_waitarray_new (aTHX_ count); OUTPUT: RETVAL SV * count (SV *self) CODE: RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]); OUTPUT: RETVAL void up (SV *self) CODE: coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), 1); void adjust (SV *self, int adjust) CODE: coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), adjust); void down (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_semaphore_down); void wait (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_semaphore_wait); void try (SV *self) PPCODE: { AV *av = (AV *)SvRV (self); SV *count_sv = AvARRAY (av)[0]; IV count = SvIVX (count_sv); if (count > 0) { --count; SvIVX (count_sv) = count; XSRETURN_YES; } else XSRETURN_NO; } void waiters (SV *self) PPCODE: { AV *av = (AV *)SvRV (self); int wcount = AvFILLp (av) + 1 - 1; if (GIMME_V == G_SCALAR) XPUSHs (sv_2mortal (newSViv (wcount))); else { int i; EXTEND (SP, wcount); for (i = 1; i <= wcount; ++i) PUSHs (sv_2mortal (newRV_inc (AvARRAY (av)[i]))); } } MODULE = Coro::State PACKAGE = Coro::SemaphoreSet void _may_delete (SV *sem, int count, unsigned int extra_refs) PPCODE: { AV *av = (AV *)SvRV (sem); if (SvREFCNT ((SV *)av) == 1 + extra_refs && AvFILLp (av) == 0 /* no waiters, just count */ && SvIV (AvARRAY (av)[0]) == count) XSRETURN_YES; XSRETURN_NO; } MODULE = Coro::State PACKAGE = Coro::Signal SV * new (SV *klass) CODE: RETVAL = sv_bless ( coro_waitarray_new (aTHX_ 0), GvSTASH (CvGV (cv)) ); OUTPUT: RETVAL void wait (...) CODE: CORO_EXECUTE_SLF_XS (slf_init_signal_wait); void broadcast (SV *self) CODE: { AV *av = (AV *)SvRV (self); coro_signal_wake (aTHX_ av, AvFILLp (av)); } void send (SV *self) CODE: { AV *av = (AV *)SvRV (self); if (AvFILLp (av)) coro_signal_wake (aTHX_ av, 1); else SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */ } IV awaited (SV *self) CODE: RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1; OUTPUT: RETVAL MODULE = Coro::State PACKAGE = Coro::AnyEvent BOOT: sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE); void _schedule (...) CODE: { static int incede; api_cede_notself (aTHX); ++incede; while (coro_nready >= incede && api_cede (aTHX)) ; sv_setsv (sv_activity, &PL_sv_undef); if (coro_nready >= incede) { PUSHMARK (SP); PUTBACK; call_pv ("Coro::AnyEvent::_activity", G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); } --incede; } MODULE = Coro::State PACKAGE = Coro::AIO void _register (char *target, char *proto, SV *req) CODE: { SV *req_cv = s_get_cv_croak (req); /* newXSproto doesn't return the CV on 5.8 */ CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__); sv_setpv ((SV *)slf_cv, proto); sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0); } MODULE = Coro::State PACKAGE = Coro::Select void patch_pp_sselect () CODE: if (!coro_old_pp_sselect) { coro_select_select = (SV *)get_cv ("Coro::Select::select", 0); coro_old_pp_sselect = PL_ppaddr [OP_SSELECT]; PL_ppaddr [OP_SSELECT] = coro_pp_sselect; } void unpatch_pp_sselect () CODE: if (coro_old_pp_sselect) { PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect; coro_old_pp_sselect = 0; } MODULE = Coro::State PACKAGE = Coro::Util void _exit (int code) CODE: _exit (code); NV time () CODE: RETVAL = nvtime (aTHX); OUTPUT: RETVAL NV gettimeofday () PPCODE: { UV tv [2]; u2time (aTHX_ tv); EXTEND (SP, 2); PUSHs (sv_2mortal (newSVuv (tv [0]))); PUSHs (sv_2mortal (newSVuv (tv [1]))); } Coro-6.57/Coro/Timer.pm0000644000000000000000000000317113710272352013377 0ustar rootroot=head1 NAME Coro::Timer - timers and timeouts, independent of any event loop =head1 SYNOPSIS # This package is mostly obsoleted by Coro::AnyEvent. use Coro::Timer qw(timeout); # nothing exported by default =head1 DESCRIPTION This package has been mostly obsoleted by L, the only really useful function left in here is C. =over 4 =cut package Coro::Timer; use common::sense; use Carp (); use base Exporter::; use Coro (); use Coro::AnyEvent (); our $VERSION = 6.57; our @EXPORT_OK = qw(timeout sleep); # compatibility with older programs *sleep = \&Coro::AnyEvent::sleep; =item $flag = timeout $seconds This function will wake up the current coroutine after $seconds seconds and sets $flag to true (it is false initially). If $flag goes out of scope earlier then nothing happens. This is used by Coro itself to implement the C, C etc. primitives. It is used like this: sub timed_wait { my $timeout = Coro::Timer::timeout 60; while (condition false) { Coro::schedule; # wait until woken up or timeout return 0 if $timeout; # timed out } return 1; # condition satisfied } =cut sub timeout($) { my $current = $Coro::current; my $timeout; bless [ \$timeout, (AE::timer $_[0], 0, sub { $timeout = 1; $current->ready; }), ], "Coro::Timer::Timeout"; } package Coro::Timer::Timeout; sub bool { ${ $_[0][0] } } use overload 'bool' => \&bool, '0+' => \&bool; 1; =back =head1 AUTHOR/SUPPORT/CONTACT Marc A. Lehmann http://software.schmorp.de/pkg/Coro.html =cut Coro-6.57/Coro/CoroAPI.h0000644000000000000000000001214613632131635013371 0ustar rootroot#ifndef CORO_API_H #define CORO_API_H #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef pTHX_ # define pTHX_ # define aTHX_ # define pTHX # define aTHX #endif /* C-level coroutine struct, opaque, not used much */ struct coro; /* used for schedule-like-function prepares */ struct coro_transfer_args { struct coro *prev, *next; }; /* this is the per-perl-coro slf frame info * it is treated like other "global" interpreter data * and unfortunately is copied around, so keep it small * * Workflow: * * 1. init function is called to parse arguments and fill out the CoroSLF frame * 2. loop starts by calling frame->prepare, providing transfer arguments * 3. transfer is called, transsferring control to another coro * 4. if at this point, the coro is destroyed: frame->destroy is called, then no further processing * 5. otherwise: eventually control is transferred back to coro * 6. frame->check is called * 7. check returns 0 => wait not finished, loop to 2 * 8. otherwise, check puts results on stack, returns 1 => finish */ struct CoroSLF { void (*prepare) (pTHX_ struct coro_transfer_args *ta); /* 0 means not yet initialised */ int (*check) (pTHX_ struct CoroSLF *frame); void *data; /* for use by prepare/check/destroy */ void (*destroy) (pTHX_ struct CoroSLF *frame); }; /* needs to fill in the *frame */ typedef void (*coro_slf_cb) (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items); /* called on enter/leave */ typedef void (*coro_enterleave_hook) (pTHX_ void *arg); /* private structure, always use the provided macros below */ struct CoroAPI { /* private */ I32 ver; I32 rev; #define CORO_API_VERSION 7 /* reorder CoroSLF on change */ #define CORO_API_REVISION 2 /* Coro */ int nready; SV *current; SV *except; void (*readyhook) (void); void (*schedule) (pTHX); void (*schedule_to) (pTHX_ SV *coro_sv); int (*cede) (pTHX); int (*cede_notself) (pTHX); int (*ready) (pTHX_ SV *coro_sv); int (*is_ready) (pTHX_ SV *coro_sv); /* Coro::State */ void (*transfer) (pTHX_ SV *prev_sv, SV *next_sv); /* Coro::State */ /* SLF */ struct coro *(*sv_state) (pTHX_ SV *coro_sv); void (*execute_slf) (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax); /* public */ /* for use as CoroSLF.prepare */ void (*prepare_nop) (pTHX_ struct coro_transfer_args *ta); void (*prepare_schedule) (pTHX_ struct coro_transfer_args *ta); void (*prepare_cede) (pTHX_ struct coro_transfer_args *ta); void (*prepare_cede_notself) (pTHX_ struct coro_transfer_args *ta); /* private */ void (*enterleave_hook)(pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg); void (*enterleave_unhook)(pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave); void (*enterleave_scope_hook)(pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg); /* XS caller must LEAVE/ENTER */ }; static struct CoroAPI *GCoroAPI; /* public API macros */ #define CORO_TRANSFER(prev,next) GCoroAPI->transfer (aTHX_ (prev), (next)) #define CORO_SV_STATE(coro) GCoroAPI->sv_state (aTHX_ (coro)) #define CORO_EXECUTE_SLF(cv,init,ax) GCoroAPI->execute_slf (aTHX_ (cv), (init), (ax)) #define CORO_EXECUTE_SLF_XS(init) CORO_EXECUTE_SLF (cv, (init), ax) #define CORO_SCHEDULE GCoroAPI->schedule (aTHX) #define CORO_CEDE GCoroAPI->cede (aTHX) #define CORO_CEDE_NOTSELF GCoroAPI->cede_notself (aTHX) #define CORO_READY(coro) GCoroAPI->ready (aTHX_ coro) #define CORO_IS_READY(coro) GCoroAPI->is_ready (coro) #define CORO_NREADY (GCoroAPI->nready) #define CORO_THROW (GCoroAPI->except) #define CORO_CURRENT SvRV (GCoroAPI->current) #define CORO_READYHOOK (GCoroAPI->readyhook) #define CORO_ENTERLEAVE_HOOK(coro,enter,enter_arg,leave,leave_arg) GCoroAPI->enterleave_hook (aTHX_ coro, enter, enter_arg, leave, leave_arg) #define CORO_ENTERLEAVE_UNHOOK(coro,enter,leave) GCoroAPI->enterleave_hook (aTHX_ coro, enter , leave ) #define CORO_ENTERLEAVE_SCOPE_HOOK(enter,enter_arg,leave,leave_arg) GCoroAPI->enterleave_scope_hook (aTHX_ enter, enter_arg, leave, leave_arg) #define I_CORO_API(YourName) \ STMT_START { \ SV *sv = perl_get_sv ("Coro::API", 0); \ if (!sv) croak ("Coro::API not found"); \ GCoroAPI = (struct CoroAPI*) SvIV (sv); \ if (GCoroAPI->ver != CORO_API_VERSION \ || GCoroAPI->rev < CORO_API_REVISION) \ croak ("Coro::API version mismatch (%d.%d vs. %d.%d) -- please recompile %s", \ (int)GCoroAPI->ver, (int)GCoroAPI->rev, CORO_API_VERSION, CORO_API_REVISION, YourName); \ } STMT_END #endif Coro-6.57/Coro/LWP.pm0000644000000000000000000000766013710272352012770 0ustar rootroot=head1 NAME Coro::LWP - make LWP non-blocking - as much as possible =head1 SYNOPSIS use Coro::LWP; # afterwards LWP should not block =head1 ALTERNATIVES Over the years, a number of less-invasive alternatives have popped up, which you might find more acceptable than this rather invasive and fragile module. All of them only support HTTP (and sometimes HTTPS). =over 4 =item L Works fine without Coro. Requires using a very different API than LWP. Probably the best choice I you can do with a completely different event-based API. =item L Makes LWP use L. Does not make LWP event-based, but allows Coro threads to schedule unimpeded through its AnyEvent integration. Lets you use the LWP API normally. =item L Basically the same as above, distinction unclear. :) =item L A different user agent implementation, not completely transparent to users, requires Coro. =back =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module tries to make L non-blocking with respect to other coroutines as much as possible, and with whatever means it takes. LWP really tries very hard to be blocking (and relies on a lot of undocumented functionality in IO::Socket), so this module had to be very invasive and must be loaded very early to take the proper effect. Note that the module L might offer an alternative to the full L that is designed to be non-blocking. Here is what it currently does (future versions of LWP might require different tricks): =over 4 =item It loads Coro::Select, overwriting the perl C) is a difficult case: sometimes being global is preferable, sometimes per-thread is preferable. Since per-thread seems to be more common, it is per-thread. =item $SIG{__DIE__} and $SIG{__WARN__} If these weren't per-thread, then common constructs such as: eval { local $SIG{__DIE__} = sub { ... }; ... }; Would not allow coroutine switching. Since exception-handling is per-thread, those variables should be per-thread as well. =item Lots of other esoteric stuff For example, C<$^H> is per-thread. Most of the additional per-thread state is not directly visible to Perl, but required to make the interpreter work. You won't normally notice these. =back Everything else is shared between all threads. For example, the globals C<$a> and C<$b> are shared. When does that matter? When using C, these variables become special, and therefore, switching threads when sorting might have surprising results. Other examples are the C<$!>, errno, C<$.>, the current input line number, C<$,>, C<$\>, C<$"> and many other special variables. While in some cases a good argument could be made for localising them to the thread, they are rarely used, and sometimes hard to localise. Future versions of Coro might include more per-thread state when it becomes a problem. =head2 Debugging Sometimes it can be useful to find out what each thread is doing (or which threads exist in the first place). The L module has (among other goodies), a function that allows you to print a "ps"-like listing - you have seen it in action earlier when Coro detected a deadlock. You use it like this: use Coro::Debug; Coro::Debug::command "ps"; Remember the example with the two channels and a worker thread that squared numbers? Running "ps" just after C<< $calculate->get >> outputs something similar to this: PID SC RSS USES Description Where 8917312 -C 22k 0 [main::] [introscript:20] 8964448 N- 152 0 [coro manager] - 8964520 N- 152 0 [unblock_sub scheduler] - 8591752 UC 152 1 [introscript:12] 11546944 N- 152 0 [EV idle process] - Interesting - there is more going on in the background than one would expect. Ignoring the extra threads, the main thread has pid C<8917312>, and the one started by C has pid C<8591752>. The latter is also the only thread that doesn't have a description, simply because we haven't set one. Setting one is easy, just put it into C<< $Coro::current->{desc} >>: async { $Coro::current->{desc} = "cruncher"; ... }; This can be rather useful when debugging a program, or when using the interactive debug shell of L. =head1 The Real World - Event Loops Coro really wants to run in a program using some event loop. In fact, most real-world programs using Coro threads are written with a combination of event-based and thread-based techniques, as it is easy to get the best of both worlds with Coro. Coro integrates automatically into any event loop supported by L (see L for details), but can take special advantage of the L and L modules. Here is a simple finger client, using whatever event loop L comes up with: use Coro; use Coro::Socket; sub finger { my ($user, $host) = @_; my $fh = new Coro::Socket PeerHost => $host, PeerPort => "finger" or die "$user\@$host: $!"; print $fh "$user\n"; print "$user\@$host: $_" while <$fh>; print "$user\@$host: done\n"; } # now finger a few accounts for ( (async { finger "abc", "cornell.edu" }), (async { finger "sebbo", "world.std.com" }), (async { finger "trouble", "noc.dfn.de" }), ) { $_->join; # wait for the result } There are a few new things here. First of all, there is L. This module works much the same way as L, except that it is coroutine-aware. This means that L, when waiting for the network, will block the whole process - that means all threads, which is clearly undesirable. On the other hand, L knows how to give up the CPU to other threads when it waits for the network, which makes parallel execution possible. The other new thing is the C method: All we want to do in this example is start three C threads and only exit when they have done their job. This could be done using a counting semaphore, but it is much simpler to synchronously wait for them to C, which is exactly what the C method does. It doesn't matter that the three Cs will probably finish in a different order then the for loop Cs them - when the thread is still running, C simply waits. If the thread has already terminated, it will simply fetch its return status. If you are experienced in event-based programming, you will see that the above program doesn't quite follow the normal pattern, where you start some work, and then run the event loop (e.v. C). In fact, nontrivial programs follow this pattern even with Coro, so a Coro program that uses EV usually looks like this: use EV; use Coro; # start coroutines or event watchers EV::loop; # and loop And in fact, for debugging, you often do something like this: use EV; use Coro::Debug; my $shell = new_unix_server Coro::Debug "/tmp/myshell"; EV::loop; # and loop This runs your program, but also an interactive shell on the unix domain socket in F. You can use the F program to access it: # socat readline /tmp/myshell coro debug session. use help for more info > ps PID SC RSS USES Description Where 136672312 RC 19k 177k [main::] [myprog:28] 136710424 -- 1268 48 [coro manager] [Coro.pm:349] > help ps [w|v] show the list of all coroutines (wide, verbose) bt show a full backtrace of coroutine eval evaluate expression in context of trace enable tracing for this coroutine untrace disable tracing for this coroutine kill throws the given string in cancel cancels this coroutine ready force into the ready queue evaluate as perl and print results & same as above, but evaluate asynchronously you can use (find_coro ) in perl expressions to find the coro with the given pid, e.g. (find_coro 9768720)->ready loglevel enable logging for messages of level and lower exit end this session Microsft victims can of course use the even less secure C constructor. =head2 The Real World - File I/O Disk I/O, while often much faster than the network, nevertheless can take quite a long time in which the CPU could do other things, if one would only be able to do something. Fortunately, the L module on CPAN allows you to move these I/O calls into the background, letting you do useful work in the foreground. It is event-/callback-based, but Coro has a nice wrapper around it, called L, which lets you use its functions naturally from within threads: use Fcntl; use Coro::AIO; my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600 or die "$filename~: $!"; aio_write $fh, 0, (length $data), $data, 0; aio_fsync $fh; aio_close $fh; aio_rename "$filename~", "$filename"; The above creates a new file, writes data into it, syncs the data to disk and atomically replaces a base file with a new copy. =head2 Inversion of control - rouse functions Last not least, me talk about inversion of control. The "control" refers to "who calls whom", who is in control of the program. In this program, the main program is in control and passes this to all functions it calls: use LWP; # pass control to get my $res = get "http://example.org/"; # control returned to us print $res; When switching to event-based programs, instead of "us calling them", "they call us" - this is the inversion of control form the title: use AnyEvent::HTTP; # do not pass control for long - http_get immediately returns http_get "http://example.org/", sub { print $_[0]; }; # we stay in control and can do other things Event based programming can be nice, but sometimes it's just easier to write down some processing in "linear" fashion, without callbacks. Coro provides some special functions to reduce typing: use AnyEvent::HTTP; # do not pass control for long - http_get immediately returns http_get "http://example.org/", Coro::rouse_cb; # we stay in control and can do other things... # ...such as wait for the result my ($res) = Coro::rouse_wait; C creates and returns a special callback. You can pass this callback to any function that would expect a callback. C waits (block the current thread) until the most recently created callback has been called, and returns whatever was passed to it. These two functions allow you to I invert the control from "callback based style" used by most event-based libraries to "blocking style", whenever you wish to. The pattern is simple: instead of... some_func ..., sub { my @res = @_; ... }; ... you write: some_func ..., Coro::rouse_cb; my @res = Coro::rouse_wait; ... Callback-based interfaces are plenty, and the rouse functions allow you to use them in an often more convenient way. =head1 Other Modules This introduction only mentions a few methods and modules, Coro has many other functions (see the L manpage) and modules (documented in the C section of the L manpage). Noteworthy modules are L (for parallel LWP requests, but see L for a better HTTP-only alternative), L, for when you need an asynchronous database, L, when you need to use any file handle in a coroutine (popular to access C and C) and L, the optimised interface to L (which gets used automatically by L). There are a number of Coro-related moduels that might be useful for your problem (see L). And since Coro integrates so well into AnyEvent, it's often easy to adapt existing AnyEvent modules (see L). =head1 AUTHOR Marc Lehmann http://home.schmorp.de/ Coro-6.57/Coro/Debug.pm0000644000000000000000000004011113710272352013340 0ustar rootroot=head1 NAME Coro::Debug - various functions that help debugging Coro programs =head1 SYNOPSIS use Coro::Debug; our $server = new_unix_server Coro::Debug "/tmp/socketpath"; $ socat readline unix:/tmp/socketpath =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module provides some debugging facilities. Most will, if not handled carefully, severely compromise the security of your program, so use it only for debugging (or take other precautions). It mainly implements a very primitive debugger that is very easy to integrate in your program: our $server = new_unix_server Coro::Debug "/tmp/somepath"; # see new_unix_server, below, for more info It lets you list running coroutines: state (rUnning, Ready, New or neither) |cctx allocated || resident set size (octets) || | scheduled this many times > ps || | | PID SC RSS USES Description Where 14572344 UC 62k 128k [main::] [dm-support.ext:47] 14620056 -- 2260 13 [coro manager] [Coro.pm:358] 14620128 -- 2260 166 [unblock_sub scheduler] [Coro.pm:358] 17764008 N- 152 0 [EV idle process] - 13990784 -- 2596 10k timeslot manager [cf.pm:454] 81424176 -- 18k 4758 [async pool idle] [Coro.pm:257] 23513336 -- 2624 1 follow handler [follow.ext:52] 40548312 -- 15k 5597 player scheduler [player-scheduler.ext:13] 29138032 -- 2548 431 music scheduler [player-env.ext:77] 43449808 -- 2260 3493 worldmap updater [item-worldmap.ext:115] 33352488 -- 19k 2845 [async pool idle] [Coro.pm:257] 81530072 -- 13k 43k map scheduler [map-scheduler.ext:65] 30751144 -- 15k 2204 [async pool idle] [Coro.pm:257] Lets you do backtraces on about any coroutine: > bt 18334288 coroutine is at /opt/cf/ext/player-env.ext line 77 eval {...} called at /opt/cf/ext/player-env.ext line 77 ext::player_env::__ANON__ called at -e line 0 Coro::_run_coro called at -e line 0 Or lets you eval perl code: > 5+7 12 Or lets you eval perl code within other coroutines: > eval 18334288 caller(1); $DB::args[0]->method 1 It can also trace subroutine entry/exits for most coroutines (those not having recursed into a C function), resulting in output similar to: > loglevel 5 > trace 94652688 2007-09-27Z20:30:25.1368 (5) [94652688] enter Socket::sockaddr_in with (8481,\x{7f}\x{00}\x{00}\x{01}) 2007-09-27Z20:30:25.1369 (5) [94652688] leave Socket::sockaddr_in returning (\x{02}\x{00}...) 2007-09-27Z20:30:25.1370 (5) [94652688] enter Net::FCP::Util::touc with (client_get) 2007-09-27Z20:30:25.1371 (5) [94652688] leave Net::FCP::Util::touc returning (ClientGet) 2007-09-27Z20:30:25.1372 (5) [94652688] enter AnyEvent::Impl::Event::io with (AnyEvent,fh,GLOB(0x9256250),poll,w,cb,CODE(0x8c963a0)) 2007-09-27Z20:30:25.1373 (5) [94652688] enter Event::Watcher::__ANON__ with (Event,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0)) 2007-09-27Z20:30:25.1374 (5) [94652688] enter Event::io::new with (Event::io,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0)) 2007-09-27Z20:30:25.1375 (5) [94652688] enter Event::Watcher::init with (Event::io=HASH(0x8bfb120),HASH(0x9b7940)) If your program uses the Coro::Debug::log facility: Coro::Debug::log 0, "important message"; Coro::Debug::log 9, "unimportant message"; Then you can even receive log messages in any debugging session: > loglevel 5 2007-09-26Z02:22:46 (9) unimportant message Other commands are available in the shell, use the C command for a list. =head1 FUNCTIONS None of the functions are being exported. =over 4 =cut package Coro::Debug; use common::sense; use overload (); use Carp (); use Scalar::Util (); use Guard; use AnyEvent (); use AnyEvent::Util (); use AnyEvent::Socket (); use Coro (); use Coro::Handle (); use Coro::State (); use Coro::AnyEvent (); use Coro::Timer (); our $VERSION = 6.57; our %log; our $SESLOGLEVEL = exists $ENV{PERL_CORO_DEFAULT_LOGLEVEL} ? $ENV{PERL_CORO_DEFAULT_LOGLEVEL} : -1; our $ERRLOGLEVEL = exists $ENV{PERL_CORO_STDERR_LOGLEVEL} ? $ENV{PERL_CORO_STDERR_LOGLEVEL} : -1; sub find_coro { my ($pid) = @_; if (my ($coro) = grep $_ == $pid, Coro::State::list) { $coro } else { print "$pid: no such coroutine\n"; undef } } sub format_msg($$) { my ($time, $micro) = Coro::Util::gettimeofday; my ($sec, $min, $hour, $day, $mon, $year) = gmtime $time; my $date = sprintf "%04d-%02d-%02dZ%02d:%02d:%02d.%04d", $year + 1900, $mon + 1, $day, $hour, $min, $sec, $micro / 100; sprintf "%s (%d) %s", $date, $_[0], $_[1] } sub format_num4($) { my ($v) = @_; return sprintf "%4d" , $v if $v < 1e4; # 1e5 redundant return sprintf "%3.0fk", $v / 1_000 if $v < 1e6; return sprintf "%1.1fM", $v / 1_000_000 if $v < 1e7 * .995; return sprintf "%3.0fM", $v / 1_000_000 if $v < 1e9; return sprintf "%1.1fG", $v / 1_000_000_000 if $v < 1e10 * .995; return sprintf "%3.0fG", $v / 1_000_000_000 if $v < 1e12; return sprintf "%1.1fT", $v / 1_000_000_000_000 if $v < 1e13 * .995; return sprintf "%3.0fT", $v / 1_000_000_000_000 if $v < 1e15; "++++" } =item log $level, $msg Log a debug message of the given severity level (0 is highest, higher is less important) to all interested parties. =item stderr_loglevel $level Set the loglevel for logging to stderr (defaults to the value of the environment variable PERL_CORO_STDERR_LOGLEVEL, or -1 if missing). =item session_loglevel $level Set the default loglevel for new coro debug sessions (defaults to the value of the environment variable PERL_CORO_DEFAULT_LOGLEVEL, or -1 if missing). =cut sub log($$) { my ($level, $msg) = @_; $msg =~ s/\s*$/\n/; $_->($level, $msg) for values %log; printf STDERR format_msg $level, $msg if $level <= $ERRLOGLEVEL; } sub session_loglevel($) { $SESLOGLEVEL = shift; } sub stderr_loglevel($) { $ERRLOGLEVEL = shift; } =item trace $coro, $loglevel Enables tracing the given coroutine at the given loglevel. If loglevel is omitted, use 5. If coro is omitted, trace the current coroutine. Tracing incurs a very high runtime overhead. It is not uncommon to enable tracing on oneself by simply calling C. A message will be logged at the given loglevel if it is not possible to enable tracing. =item untrace $coro Disables tracing on the given coroutine. =cut sub trace { my ($coro, $loglevel) = @_; $coro ||= $Coro::current; $loglevel = 5 unless defined $loglevel; (Coro::async { if (eval { Coro::State::trace $coro, Coro::State::CC_TRACE | Coro::State::CC_TRACE_SUB; 1 }) { Coro::Debug::log $loglevel, sprintf "[%d] tracing enabled", $coro + 0; $coro->{_trace_line_cb} = sub { Coro::Debug::log $loglevel, sprintf "[%d] at %s:%d\n", $Coro::current+0, @_; }; $coro->{_trace_sub_cb} = sub { Coro::Debug::log $loglevel, sprintf "[%d] %s %s %s\n", $Coro::current+0, $_[0] ? "enter" : "leave", $_[1], $_[2] ? ($_[0] ? "with (" : "returning (") . ( join ",", map { my $x = ref $_ ? overload::StrVal $_ : $_; (substr $x, 40) = "..." if 40 + 3 < length $x; $x =~ s/([^\x20-\x5b\x5d-\x7e])/sprintf "\\x{%02x}", ord $1/ge; $x } @{$_[2]} ) . ")" : ""; }; undef $coro; # the subs keep a reference which we do not want them to do } else { Coro::Debug::log $loglevel, sprintf "[%d] unable to enable tracing: %s", $Coro::current + 0, $@; } })->prio (Coro::PRIO_MAX); Coro::cede; } sub untrace { my ($coro) = @_; $coro ||= $Coro::current; (Coro::async { Coro::State::trace $coro, 0; delete $coro->{_trace_sub_cb}; delete $coro->{_trace_line_cb}; })->prio (Coro::PRIO_MAX); Coro::cede; } sub ps_listing { my $times = Coro::State::enable_times; my $flags = $1; my $verbose = $flags =~ /v/; my $desc_format = $flags =~ /w/ ? "%-24s" : "%-24.24s"; my $tim0_format = $times ? " %9s %8s " : " "; my $tim1_format = $times ? " %9.3f %8.3f " : " "; my $buf = sprintf "%20s %s%s %4s %4s$tim0_format$desc_format %s\n", "PID", "S", "C", "RSS", "USES", $times ? ("t_real", "t_cpu") : (), "Description", "Where"; for my $coro (reverse Coro::State::list) { my @bt; Coro::State::call ($coro, sub { # we try to find *the* definite frame that gives most useful info # by skipping Coro frames and pseudo-frames. for my $frame (1..10) { my @frame = caller $frame; @bt = @frame if $frame[2]; last unless $bt[0] =~ /^Coro/; } }); $bt[1] =~ s/^.*[\/\\]// if @bt && !$verbose; $buf .= sprintf "%20s %s%s %4s %4s$tim1_format$desc_format %s\n", $coro+0, $coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-", $coro->is_traced ? "T" : $coro->has_cctx ? "C" : "-", format_num4 $coro->rss, format_num4 $coro->usecount, $times ? $coro->times : (), $coro->debug_desc, (@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-"); } $buf } =item command $string Execute a debugger command, sending any output to STDOUT. Used by C, below. =cut sub command($) { my ($cmd) = @_; $cmd =~ s/\s+$//; if ($cmd =~ /^ps (?:\s* (\S+))? $/x) { print ps_listing; } elsif ($cmd =~ /^bt\s+(\d+)$/) { if (my $coro = find_coro $1) { my $bt; Coro::State::call ($coro, sub { local $Carp::CarpLevel = 2; $bt = eval { Carp::longmess "coroutine is" } || "$@"; }); if ($bt) { print $bt; } else { print "$1: unable to get backtrace\n"; } } } elsif ($cmd =~ /^(?:e|eval)\s+(\d+)\s+(.*)$/) { if (my $coro = find_coro $1) { my $cmd = eval "sub { $2 }"; my @res; Coro::State::call ($coro, sub { @res = eval { &$cmd } }); print $@ ? $@ : (join " ", @res, "\n"); } } elsif ($cmd =~ /^(?:tr|trace)\s+(\d+)$/) { if (my $coro = find_coro $1) { trace $coro; } } elsif ($cmd =~ /^(?:ut|untrace)\s+(\d+)$/) { if (my $coro = find_coro $1) { untrace $coro; } } elsif ($cmd =~ /^cancel\s+(\d+)$/) { if (my $coro = find_coro $1) { $coro->cancel; } } elsif ($cmd =~ /^ready\s+(\d+)$/) { if (my $coro = find_coro $1) { $coro->ready; } } elsif ($cmd =~ /^kill\s+(\d+)(?:\s+(.*))?$/) { my $reason = defined $2 ? $2 : "killed"; if (my $coro = find_coro $1) { $coro->throw ($reason); } } elsif ($cmd =~ /^enable_times(\s+\S.*)?\s*$/) { my $enable = defined $1 ? 1*eval $1 : !Coro::State::enable_times; Coro::State::enable_times $enable; print "per-thread real and process time gathering ", $enable ? "enabled" : "disabled", ".\n"; } elsif ($cmd =~ /^help$/) { print < show a full backtrace of coroutine eval evaluate expression in context of trace enable tracing for this coroutine untrace disable tracing for this coroutine kill throws the given string in cancel cancels this coroutine ready force into the ready queue enable_times enable or disable time profiling in ps evaluate as perl and print results & same as above, but evaluate asynchronously you can use (find_coro ) in perl expressions to find the coro with the given pid, e.g. (find_coro 9768720)->ready EOF } elsif ($cmd =~ /^(.*)&$/) { my $cmd = $1; my $sub = eval "sub { $cmd }"; my $fh = select; Coro::async_pool { $Coro::current->{desc} = $cmd; my $t = Coro::Util::time; my @res = eval { &$sub }; $t = Coro::Util::time - $t; print {$fh} "\rcommand: $cmd\n", "execution time: $t\n", "result: ", $@ ? $@ : (join " ", @res) . "\n", "> "; }; } else { my @res = eval $cmd; print $@ ? $@ : (join " ", @res) . "\n"; } local $| = 1; } =item session $fh Run an interactive debugger session on the given filehandle. Each line entered is simply passed to C (with a few exceptions). =cut sub session($) { my ($fh) = @_; $fh = Coro::Handle::unblock $fh; my $old_fh = select $fh; my $guard = guard { select $old_fh }; my $loglevel = $SESLOGLEVEL; local $log{$Coro::current} = sub { return unless $_[0] <= $loglevel; print $fh "\015", (format_msg $_[0], $_[1]), "> "; }; print "coro debug session. use help for more info\n\n"; while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) { if ($cmd =~ /^exit\s*$/) { print "bye.\n"; last; } elsif ($cmd =~ /^(?:ll|loglevel)\s*(\d+)?\s*/) { $loglevel = defined $1 ? $1 : -1; } elsif ($cmd =~ /^(?:w|watch)\s*([0-9.]*)\s+(.*)/) { my ($time, $cmd) = ($1*1 || 1, $2); my $cancel; Coro::async { $Coro::current->{desc} = "watch $cmd"; select $fh; until ($cancel) { command $cmd; Coro::Timer::sleep $time; } }; $fh->readable; $cancel = 1; } elsif ($cmd =~ /^help\s*/) { command $cmd; print < enable logging for messages of level and lower watch