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

Comparing Coro/Coro.pm (file contents):
Revision 1.98 by root, Mon Dec 4 21:56:00 2006 UTC vs.
Revision 1.108 by root, Fri Jan 5 20:00:49 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.1'; 55our $VERSION = '3.3';
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 $coro->{status} ||= [];
159 $_->ready for @{delete $coro->{join} || []};
160 167
161 # the next line destroys the coro state, but keeps the
162 # coroutine itself intact (we basically make it a zombie
163 # coroutine that always runs the manager thread, so it's possible
164 # to transfer() to this coroutine).
165 $coro->_clone_state_from ($manager);
166 }
167 &schedule; 168 &schedule;
168 } 169 }
169}; 170};
171
172$manager->prio (PRIO_MAX);
170 173
171# static methods. not really. 174# static methods. not really.
172 175
173=back 176=back
174 177
… …
195 } 1,2,3,4; 198 } 1,2,3,4;
196 199
197=cut 200=cut
198 201
199sub async(&@) { 202sub async(&@) {
200 my $pid = new Coro @_; 203 my $coro = new Coro @_;
201 $pid->ready; 204 $coro->ready;
202 $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 my ($cb, @arg) = @{ delete $current->{_invoke} };
239
240 eval {
241 $cb->(@arg);
242 };
243 warn $@ if $@;
244
245 last if @pool >= $POOL_SIZE;
246 push @pool, $current;
247
248 $current->prio (0);
249 schedule;
250 }
251}
252
253sub async_pool(&@) {
254 # this is also inlined into the unlock_scheduler
255 my $coro = (pop @pool or new Coro \&pool_handler);
256
257 $coro->{_invoke} = [@_];
258 $coro->ready;
259
260 $coro
203} 261}
204 262
205=item schedule 263=item schedule
206 264
207Calls the scheduler. Please note that the current coroutine will not be put 265Calls the scheduler. Please note that the current coroutine will not be put
… …
232 290
233"Cede" to other coroutines. This function puts the current coroutine into the 291"Cede" to other coroutines. This function puts the current coroutine into the
234ready queue and calls C<schedule>, which has the effect of giving up the 292ready queue and calls C<schedule>, which has the effect of giving up the
235current "timeslice" to other coroutines of the same or higher priority. 293current "timeslice" to other coroutines of the same or higher priority.
236 294
295Returns true if at least one coroutine switch has happened.
296
297=item Coro::cede_notself
298
299Works like cede, but is not exported by default and will cede to any
300coroutine, regardless of priority, once.
301
302Returns true if at least one coroutine switch has happened.
303
237=item terminate [arg...] 304=item terminate [arg...]
238 305
239Terminates the current coroutine with the given status values (see L<cancel>). 306Terminates the current coroutine with the given status values (see L<cancel>).
240 307
241=cut 308=cut
… …
286Return wether the coroutine is currently the ready queue or not, 353Return wether the coroutine is currently the ready queue or not,
287 354
288=item $coroutine->cancel (arg...) 355=item $coroutine->cancel (arg...)
289 356
290Terminates the given coroutine and makes it return the given arguments as 357Terminates the given coroutine and makes it return the given arguments as
291status (default: the empty list). 358status (default: the empty list). Never returns if the coroutine is the
359current coroutine.
292 360
293=cut 361=cut
294 362
295sub cancel { 363sub cancel {
296 my $self = shift; 364 my $self = shift;
297 $self->{status} = [@_]; 365 $self->{status} = [@_];
366
367 if ($current == $self) {
298 push @destroy, $self; 368 push @destroy, $self;
299 $manager->ready; 369 $manager->ready;
300 &schedule if $current == $self; 370 &schedule while 1;
371 } else {
372 $self->_cancel;
373 }
301} 374}
302 375
303=item $coroutine->join 376=item $coroutine->join
304 377
305Wait until the coroutine terminates and return any values given to the 378Wait until the coroutine terminates and return any values given to the
… …
308 381
309=cut 382=cut
310 383
311sub join { 384sub join {
312 my $self = shift; 385 my $self = shift;
386
313 unless ($self->{status}) { 387 unless ($self->{status}) {
314 push @{$self->{join}}, $current; 388 my $current = $current;
315 &schedule; 389
390 push @{$self->{destroy_cb}}, sub {
391 $current->ready;
392 undef $current;
393 };
394
395 &schedule while $current;
316 } 396 }
397
317 wantarray ? @{$self->{status}} : $self->{status}[0]; 398 wantarray ? @{$self->{status}} : $self->{status}[0];
399}
400
401=item $coroutine->on_destroy (\&cb)
402
403Registers a callback that is called when this coroutine gets destroyed,
404but before it is joined. The callback gets passed the terminate arguments,
405if any.
406
407=cut
408
409sub on_destroy {
410 my ($self, $cb) = @_;
411
412 push @{ $self->{destroy_cb} }, $cb;
318} 413}
319 414
320=item $oldprio = $coroutine->prio ($newprio) 415=item $oldprio = $coroutine->prio ($newprio)
321 416
322Sets (or gets, if the argument is missing) the priority of the 417Sets (or gets, if the argument is missing) the priority of the
… …
369i.e. that can be swicthed to. The value C<0> means that the only runnable 464i.e. that can be swicthed to. The value C<0> means that the only runnable
370coroutine is the currently running one, so C<cede> would have no effect, 465coroutine is the currently running one, so C<cede> would have no effect,
371and C<schedule> would cause a deadlock unless there is an idle handler 466and C<schedule> would cause a deadlock unless there is an idle handler
372that wakes up some coroutines. 467that wakes up some coroutines.
373 468
469=item my $guard = Coro::guard { ... }
470
471This creates and returns a guard object. Nothing happens until the objetc
472gets destroyed, in which case the codeblock given as argument will be
473executed. This is useful to free locks or other resources in case of a
474runtime error or when the coroutine gets canceled, as in both cases the
475guard block will be executed. The guard object supports only one method,
476C<< ->cancel >>, which will keep the codeblock from being executed.
477
478Example: set some flag and clear it again when the coroutine gets canceled
479or the function returns:
480
481 sub do_something {
482 my $guard = Coro::guard { $busy = 0 };
483 $busy = 1;
484
485 # do something that requires $busy to be true
486 }
487
488=cut
489
490sub guard(&) {
491 bless \(my $cb = $_[0]), "Coro::guard"
492}
493
494sub Coro::guard::cancel {
495 ${$_[0]} = sub { };
496}
497
498sub Coro::guard::DESTROY {
499 ${$_[0]}->();
500}
501
502
374=item unblock_sub { ... } 503=item unblock_sub { ... }
375 504
376This utility function takes a BLOCK or code reference and "unblocks" it, 505This utility function takes a BLOCK or code reference and "unblocks" it,
377returning the new coderef. This means that the new coderef will return 506returning the new coderef. This means that the new coderef will return
378immediately without blocking, returning nothing, while the original code 507immediately without blocking, returning nothing, while the original code
… …
391In short: simply use C<unblock_sub { ... }> instead of C<sub { ... }> when 520In short: simply use C<unblock_sub { ... }> instead of C<sub { ... }> when
392creating event callbacks that want to block. 521creating event callbacks that want to block.
393 522
394=cut 523=cut
395 524
396our @unblock_pool;
397our @unblock_queue; 525our @unblock_queue;
398our $UNBLOCK_POOL_SIZE = 2;
399 526
400sub unblock_handler_ { 527# we create a special coro because we want to cede,
401 while () { 528# to reduce pressure on the coro pool (because most callbacks
402 my ($cb, @arg) = @{ delete $Coro::current->{arg} }; 529# return immediately and can be reused) and because we cannot cede
403 $cb->(@arg); 530# inside an event callback.
404
405 last if @unblock_pool >= $UNBLOCK_POOL_SIZE;
406 push @unblock_pool, $Coro::current;
407 schedule;
408 }
409}
410
411our $unblock_scheduler = async { 531our $unblock_scheduler = async {
412 while () { 532 while () {
413 while (my $cb = pop @unblock_queue) { 533 while (my $cb = pop @unblock_queue) {
534 # this is an inlined copy of async_pool
414 my $handler = (pop @unblock_pool or new Coro \&unblock_handler_); 535 my $coro = (pop @pool or new Coro \&pool_handler);
415 $handler->{arg} = $cb; 536
537 $coro->{_invoke} = $cb;
416 $handler->ready; 538 $coro->ready;
417 cede; 539 cede; # for short-lived callbacks, this reduces pressure on the coro pool
418 } 540 }
419 541 schedule; # sleep well
420 schedule;
421 } 542 }
422}; 543};
423 544
424sub unblock_sub(&) { 545sub unblock_sub(&) {
425 my $cb = shift; 546 my $cb = shift;
426 547
427 sub { 548 sub {
428 push @unblock_queue, [$cb, @_]; 549 unshift @unblock_queue, [$cb, @_];
429 $unblock_scheduler->ready; 550 $unblock_scheduler->ready;
430 } 551 }
431} 552}
432 553
433=back 554=back

Diff Legend

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