ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro.pm
(Generate patch)

Comparing Coro/Coro.pm (file contents):
Revision 1.101 by root, Fri Dec 29 08:36:34 2006 UTC vs.
Revision 1.114 by root, Wed Jan 24 16:22:08 2007 UTC

… …
50 50
51our $idle; # idle handler 51our $idle; # idle handler
52our $main; # main coroutine 52our $main; # main coroutine
53our $current; # current coroutine 53our $current; # current coroutine
54 54
55our $VERSION = '3.3'; 55our $VERSION = '3.5';
56 56
57our @EXPORT = qw(async cede schedule terminate current unblock_sub); 57our @EXPORT = qw(async async_pool cede schedule terminate current unblock_sub);
58our %EXPORT_TAGS = ( 58our %EXPORT_TAGS = (
59 prio => [qw(PRIO_MAX PRIO_HIGH PRIO_NORMAL PRIO_LOW PRIO_IDLE PRIO_MIN)], 59 prio => [qw(PRIO_MAX PRIO_HIGH PRIO_NORMAL PRIO_LOW PRIO_IDLE PRIO_MIN)],
60); 60);
61our @EXPORT_OK = (@{$EXPORT_TAGS{prio}}, qw(nready)); 61our @EXPORT_OK = (@{$EXPORT_TAGS{prio}}, qw(nready));
62 62
… …
141$idle = sub { 141$idle = sub {
142 require Carp; 142 require Carp;
143 Carp::croak ("FATAL: deadlock detected"); 143 Carp::croak ("FATAL: deadlock detected");
144}; 144};
145 145
146sub _cancel {
147 my ($self) = @_;
148
149 # free coroutine data and mark as destructed
150 $self->_destroy
151 or return;
152
153 # call all destruction callbacks
154 $_->(@{$self->{status}})
155 for @{(delete $self->{destroy_cb}) || []};
156}
157
146# this coroutine is necessary because a coroutine 158# this coroutine is necessary because a coroutine
147# cannot destroy itself. 159# cannot destroy itself.
148my @destroy; 160my @destroy;
161my $manager;
162
149my $manager; $manager = new Coro sub { 163$manager = new Coro sub {
150 while () { 164 while () {
151 # by overwriting the state object with the manager we destroy it 165 (shift @destroy)->_cancel
152 # while still being able to schedule this coroutine (in case it has
153 # been readied multiple times. this is harmless since the manager
154 # can be called as many times as neccessary and will always
155 # remove itself from the runqueue
156 while (@destroy) { 166 while @destroy;
157 my $coro = pop @destroy;
158 167
159 $coro->{status} ||= [];
160
161 $_->ready for @{(delete $coro->{join} ) || []};
162 $_->(@{$coro->{status}}) for @{(delete $coro->{destroy_cb}) || []};
163
164 # the next line destroys the coro state, but keeps the
165 # coroutine itself intact (we basically make it a zombie
166 # coroutine that always runs the manager thread, so it's possible
167 # to transfer() to this coroutine).
168 $coro->_clone_state_from ($manager);
169 }
170 &schedule; 168 &schedule;
171 } 169 }
172}; 170};
171
172$manager->prio (PRIO_MAX);
173 173
174# static methods. not really. 174# static methods. not really.
175 175
176=back 176=back
177 177
… …
198 } 1,2,3,4; 198 } 1,2,3,4;
199 199
200=cut 200=cut
201 201
202sub async(&@) { 202sub async(&@) {
203 my $pid = new Coro @_; 203 my $coro = new Coro @_;
204 $pid->ready; 204 $coro->ready;
205 $pid 205 $coro
206}
207
208=item async_pool { ... } [@args...]
209
210Similar to C<async>, but uses a coroutine pool, so you should not call
211terminate or join (although you are allowed to), and you get a coroutine
212that might have executed other code already (which can be good or bad :).
213
214Also, the block is executed in an C<eval> context and a warning will be
215issued in case of an exception instead of terminating the program, as
216C<async> does. As the coroutine is being reused, stuff like C<on_destroy>
217will not work in the expected way, unless you call terminate or cancel,
218which somehow defeats the purpose of pooling.
219
220The priority will be reset to C<0> after each job, otherwise the coroutine
221will be re-used "as-is".
222
223The pool size is limited to 8 idle coroutines (this can be adjusted by
224changing $Coro::POOL_SIZE), and there can be as many non-idle coros as
225required.
226
227If you are concerned about pooled coroutines growing a lot because a
228single C<async_pool> used a lot of stackspace you can e.g. C<async_pool {
229terminate }> once per second or so to slowly replenish the pool.
230
231=cut
232
233our $POOL_SIZE = 8;
234our @pool;
235
236sub pool_handler {
237 while () {
238 eval {
239 my ($cb, @arg) = @{ delete $current->{_invoke} or return };
240 $cb->(@arg);
241 };
242 warn $@ if $@;
243
244 last if @pool >= $POOL_SIZE;
245 push @pool, $current;
246
247 $current->prio (0);
248 schedule;
249 }
250}
251
252sub async_pool(&@) {
253 # this is also inlined into the unlock_scheduler
254 my $coro = (pop @pool or new Coro \&pool_handler);
255
256 $coro->{_invoke} = [@_];
257 $coro->ready;
258
259 $coro
206} 260}
207 261
208=item schedule 262=item schedule
209 263
210Calls the scheduler. Please note that the current coroutine will not be put 264Calls the scheduler. Please note that the current coroutine will not be put
… …
235 289
236"Cede" to other coroutines. This function puts the current coroutine into the 290"Cede" to other coroutines. This function puts the current coroutine into the
237ready queue and calls C<schedule>, which has the effect of giving up the 291ready queue and calls C<schedule>, which has the effect of giving up the
238current "timeslice" to other coroutines of the same or higher priority. 292current "timeslice" to other coroutines of the same or higher priority.
239 293
294Returns true if at least one coroutine switch has happened.
295
296=item Coro::cede_notself
297
298Works like cede, but is not exported by default and will cede to any
299coroutine, regardless of priority, once.
300
301Returns true if at least one coroutine switch has happened.
302
240=item terminate [arg...] 303=item terminate [arg...]
241 304
242Terminates the current coroutine with the given status values (see L<cancel>). 305Terminates the current coroutine with the given status values (see L<cancel>).
243 306
244=cut 307=cut
… …
289Return wether the coroutine is currently the ready queue or not, 352Return wether the coroutine is currently the ready queue or not,
290 353
291=item $coroutine->cancel (arg...) 354=item $coroutine->cancel (arg...)
292 355
293Terminates the given coroutine and makes it return the given arguments as 356Terminates the given coroutine and makes it return the given arguments as
294status (default: the empty list). 357status (default: the empty list). Never returns if the coroutine is the
358current coroutine.
295 359
296=cut 360=cut
297 361
298sub cancel { 362sub cancel {
299 my $self = shift; 363 my $self = shift;
300 $self->{status} = [@_]; 364 $self->{status} = [@_];
365
366 if ($current == $self) {
301 push @destroy, $self; 367 push @destroy, $self;
302 $manager->ready; 368 $manager->ready;
303 &schedule if $current == $self; 369 &schedule while 1;
370 } else {
371 $self->_cancel;
372 }
304} 373}
305 374
306=item $coroutine->join 375=item $coroutine->join
307 376
308Wait until the coroutine terminates and return any values given to the 377Wait until the coroutine terminates and return any values given to the
… …
311 380
312=cut 381=cut
313 382
314sub join { 383sub join {
315 my $self = shift; 384 my $self = shift;
385
316 unless ($self->{status}) { 386 unless ($self->{status}) {
317 push @{$self->{join}}, $current; 387 my $current = $current;
318 &schedule; 388
389 push @{$self->{destroy_cb}}, sub {
390 $current->ready;
391 undef $current;
392 };
393
394 &schedule while $current;
319 } 395 }
396
320 wantarray ? @{$self->{status}} : $self->{status}[0]; 397 wantarray ? @{$self->{status}} : $self->{status}[0];
321} 398}
322 399
323=item $coroutine->on_destroy (\&cb) 400=item $coroutine->on_destroy (\&cb)
324 401
… …
386i.e. that can be swicthed to. The value C<0> means that the only runnable 463i.e. that can be swicthed to. The value C<0> means that the only runnable
387coroutine is the currently running one, so C<cede> would have no effect, 464coroutine is the currently running one, so C<cede> would have no effect,
388and C<schedule> would cause a deadlock unless there is an idle handler 465and C<schedule> would cause a deadlock unless there is an idle handler
389that wakes up some coroutines. 466that wakes up some coroutines.
390 467
468=item my $guard = Coro::guard { ... }
469
470This creates and returns a guard object. Nothing happens until the objetc
471gets destroyed, in which case the codeblock given as argument will be
472executed. This is useful to free locks or other resources in case of a
473runtime error or when the coroutine gets canceled, as in both cases the
474guard block will be executed. The guard object supports only one method,
475C<< ->cancel >>, which will keep the codeblock from being executed.
476
477Example: set some flag and clear it again when the coroutine gets canceled
478or the function returns:
479
480 sub do_something {
481 my $guard = Coro::guard { $busy = 0 };
482 $busy = 1;
483
484 # do something that requires $busy to be true
485 }
486
487=cut
488
489sub guard(&) {
490 bless \(my $cb = $_[0]), "Coro::guard"
491}
492
493sub Coro::guard::cancel {
494 ${$_[0]} = sub { };
495}
496
497sub Coro::guard::DESTROY {
498 ${$_[0]}->();
499}
500
501
391=item unblock_sub { ... } 502=item unblock_sub { ... }
392 503
393This utility function takes a BLOCK or code reference and "unblocks" it, 504This utility function takes a BLOCK or code reference and "unblocks" it,
394returning the new coderef. This means that the new coderef will return 505returning the new coderef. This means that the new coderef will return
395immediately without blocking, returning nothing, while the original code 506immediately without blocking, returning nothing, while the original code
… …
408In short: simply use C<unblock_sub { ... }> instead of C<sub { ... }> when 519In short: simply use C<unblock_sub { ... }> instead of C<sub { ... }> when
409creating event callbacks that want to block. 520creating event callbacks that want to block.
410 521
411=cut 522=cut
412 523
413our @unblock_pool;
414our @unblock_queue; 524our @unblock_queue;
415our $UNBLOCK_POOL_SIZE = 2;
416 525
417sub unblock_handler_ { 526# we create a special coro because we want to cede,
418 while () { 527# to reduce pressure on the coro pool (because most callbacks
419 my ($cb, @arg) = @{ delete $Coro::current->{arg} }; 528# return immediately and can be reused) and because we cannot cede
420 $cb->(@arg); 529# inside an event callback.
421
422 last if @unblock_pool >= $UNBLOCK_POOL_SIZE;
423 push @unblock_pool, $Coro::current;
424 schedule;
425 }
426}
427
428our $unblock_scheduler = async { 530our $unblock_scheduler = async {
429 while () { 531 while () {
430 while (my $cb = pop @unblock_queue) { 532 while (my $cb = pop @unblock_queue) {
533 # this is an inlined copy of async_pool
431 my $handler = (pop @unblock_pool or new Coro \&unblock_handler_); 534 my $coro = (pop @pool or new Coro \&pool_handler);
432 $handler->{arg} = $cb; 535
536 $coro->{_invoke} = $cb;
433 $handler->ready; 537 $coro->ready;
434 cede; 538 cede; # for short-lived callbacks, this reduces pressure on the coro pool
435 } 539 }
436 540 schedule; # sleep well
437 schedule;
438 } 541 }
439}; 542};
440 543
441sub unblock_sub(&) { 544sub unblock_sub(&) {
442 my $cb = shift; 545 my $cb = shift;
443 546
444 sub { 547 sub {
445 push @unblock_queue, [$cb, @_]; 548 unshift @unblock_queue, [$cb, @_];
446 $unblock_scheduler->ready; 549 $unblock_scheduler->ready;
447 } 550 }
448} 551}
449 552
450=back 553=back

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines