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

Comparing cvsroot/Coro/Coro.pm (file contents):
Revision 1.54 by pcg, Sun Sep 28 09:00:48 2003 UTC vs.
Revision 1.97 by root, Mon Dec 4 13:47:56 2006 UTC

… …
8 8
9 async { 9 async {
10 # some asynchronous thread of execution 10 # some asynchronous thread of execution
11 }; 11 };
12 12
13 # alternatively create an async process like this: 13 # alternatively create an async coroutine like this:
14 14
15 sub some_func : Coro { 15 sub some_func : Coro {
16 # some more async code 16 # some more async code
17 } 17 }
18 18
… …
30 30
31=cut 31=cut
32 32
33package Coro; 33package Coro;
34 34
35use strict;
35no warnings qw(uninitialized); 36no warnings "uninitialized";
36 37
37use Coro::State; 38use Coro::State;
38 39
39use base Exporter; 40use base qw(Coro::State Exporter);
40 41
41$VERSION = 0.7; 42our $idle; # idle handler
43our $main; # main coroutine
44our $current; # current coroutine
42 45
46our $VERSION = '3.01';
47
43@EXPORT = qw(async cede schedule terminate current); 48our @EXPORT = qw(async cede schedule terminate current unblock_sub);
44%EXPORT_TAGS = ( 49our %EXPORT_TAGS = (
45 prio => [qw(PRIO_MAX PRIO_HIGH PRIO_NORMAL PRIO_LOW PRIO_IDLE PRIO_MIN)], 50 prio => [qw(PRIO_MAX PRIO_HIGH PRIO_NORMAL PRIO_LOW PRIO_IDLE PRIO_MIN)],
46); 51);
47@EXPORT_OK = @{$EXPORT_TAGS{prio}}; 52our @EXPORT_OK = (@{$EXPORT_TAGS{prio}}, qw(nready));
48 53
49{ 54{
50 my @async; 55 my @async;
51 my $init; 56 my $init;
52 57
53 # this way of handling attributes simply is NOT scalable ;() 58 # this way of handling attributes simply is NOT scalable ;()
54 sub import { 59 sub import {
60 no strict 'refs';
61
55 Coro->export_to_level(1, @_); 62 Coro->export_to_level (1, @_);
63
56 my $old = *{(caller)[0]."::MODIFY_CODE_ATTRIBUTES"}{CODE}; 64 my $old = *{(caller)[0]."::MODIFY_CODE_ATTRIBUTES"}{CODE};
57 *{(caller)[0]."::MODIFY_CODE_ATTRIBUTES"} = sub { 65 *{(caller)[0]."::MODIFY_CODE_ATTRIBUTES"} = sub {
58 my ($package, $ref) = (shift, shift); 66 my ($package, $ref) = (shift, shift);
59 my @attrs; 67 my @attrs;
60 for (@_) { 68 for (@_) {
… …
83 91
84This coroutine represents the main program. 92This coroutine represents the main program.
85 93
86=cut 94=cut
87 95
88our $main = new Coro; 96$main = new Coro;
89 97
90=item $current (or as function: current) 98=item $current (or as function: current)
91 99
92The current coroutine (the last coroutine switched to). The initial value is C<$main> (of course). 100The current coroutine (the last coroutine switched to). The initial value
101is C<$main> (of course).
102
103This variable is B<strictly> I<read-only>. It is provided for performance
104reasons. If performance is not essentiel you are encouraged to use the
105C<Coro::current> function instead.
93 106
94=cut 107=cut
95 108
96# maybe some other module used Coro::Specific before... 109# maybe some other module used Coro::Specific before...
97if ($current) {
98 $main->{specific} = $current->{specific}; 110$main->{specific} = $current->{specific}
99} 111 if $current;
100 112
101our $current = $main; 113_set_current $main;
102 114
103sub current() { $current } 115sub current() { $current }
104 116
105=item $idle 117=item $idle
106 118
107The coroutine to switch to when no other coroutine is running. The default 119A callback that is called whenever the scheduler finds no ready coroutines
108implementation prints "FATAL: deadlock detected" and exits. 120to run. The default implementation prints "FATAL: deadlock detected" and
121exits, because the program has no other way to continue.
109 122
110=cut 123This hook is overwritten by modules such as C<Coro::Timer> and
124C<Coro::Event> to wait on an external event that hopefully wake up a
125coroutine so the scheduler can run it.
111 126
112# should be done using priorities :( 127Please note that if your callback recursively invokes perl (e.g. for event
113our $idle = new Coro sub { 128handlers), then it must be prepared to be called recursively.
114 print STDERR "FATAL: deadlock detected\n"; 129
115 exit(51); 130=cut
131
132$idle = sub {
133 require Carp;
134 Carp::croak ("FATAL: deadlock detected");
116}; 135};
117 136
118# this coroutine is necessary because a coroutine 137# this coroutine is necessary because a coroutine
119# cannot destroy itself. 138# cannot destroy itself.
120my @destroy; 139my @destroy;
121my $manager;
122$manager = new Coro sub { 140my $manager; $manager = new Coro sub {
123 while() { 141 while () {
124 # by overwriting the state object with the manager we destroy it 142 # by overwriting the state object with the manager we destroy it
125 # while still being able to schedule this coroutine (in case it has 143 # while still being able to schedule this coroutine (in case it has
126 # been readied multiple times. this is harmless since the manager 144 # been readied multiple times. this is harmless since the manager
127 # can be called as many times as neccessary and will always 145 # can be called as many times as neccessary and will always
128 # remove itself from the runqueue 146 # remove itself from the runqueue
129 while (@destroy) { 147 while (@destroy) {
130 my $coro = pop @destroy; 148 my $coro = pop @destroy;
131 $coro->{status} ||= []; 149 $coro->{status} ||= [];
132 $_->ready for @{delete $coro->{join} || []}; 150 $_->ready for @{delete $coro->{join} || []};
133 $coro->{_coro_state} = $manager->{_coro_state}; 151
152 # the next line destroys the coro state, but keeps the
153 # coroutine itself intact (we basically make it a zombie
154 # coroutine that always runs the manager thread, so it's possible
155 # to transfer() to this coroutine).
156 $coro->_clone_state_from ($manager);
134 } 157 }
135 &schedule; 158 &schedule;
136 } 159 }
137}; 160};
138 161
… …
140 163
141=back 164=back
142 165
143=head2 STATIC METHODS 166=head2 STATIC METHODS
144 167
145Static methods are actually functions that operate on the current process only. 168Static methods are actually functions that operate on the current coroutine only.
146 169
147=over 4 170=over 4
148 171
149=item async { ... } [@args...] 172=item async { ... } [@args...]
150 173
151Create a new asynchronous process and return it's process object 174Create a new asynchronous coroutine and return it's coroutine object
152(usually unused). When the sub returns the new process is automatically 175(usually unused). When the sub returns the new coroutine is automatically
153terminated. 176terminated.
177
178Calling C<exit> in a coroutine will not work correctly, so do not do that.
179
180When the coroutine dies, the program will exit, just as in the main
181program.
154 182
155 # create a new coroutine that just prints its arguments 183 # create a new coroutine that just prints its arguments
156 async { 184 async {
157 print "@_\n"; 185 print "@_\n";
158 } 1,2,3,4; 186 } 1,2,3,4;
159 187
160The coderef you submit MUST NOT be a closure that refers to variables
161in an outer scope. This does NOT work. Pass arguments into it instead.
162
163=cut 188=cut
164 189
165sub async(&@) { 190sub async(&@) {
166 my $pid = new Coro @_; 191 my $pid = new Coro @_;
167 $manager->ready; # this ensures that the stack is cloned from the manager
168 $pid->ready; 192 $pid->ready;
169 $pid; 193 $pid
170} 194}
171 195
172=item schedule 196=item schedule
173 197
174Calls the scheduler. Please note that the current process will not be put 198Calls the scheduler. Please note that the current coroutine will not be put
175into the ready queue, so calling this function usually means you will 199into the ready queue, so calling this function usually means you will
176never be called again. 200never be called again unless something else (e.g. an event handler) calls
201ready.
177 202
178=cut 203The canonical way to wait on external events is this:
204
205 {
206 # remember current coroutine
207 my $current = $Coro::current;
208
209 # register a hypothetical event handler
210 on_event_invoke sub {
211 # wake up sleeping coroutine
212 $current->ready;
213 undef $current;
214 };
215
216 # call schedule until event occured.
217 # in case we are woken up for other reasons
218 # (current still defined), loop.
219 Coro::schedule while $current;
220 }
179 221
180=item cede 222=item cede
181 223
182"Cede" to other processes. This function puts the current process into the 224"Cede" to other coroutines. This function puts the current coroutine into the
183ready queue and calls C<schedule>, which has the effect of giving up the 225ready queue and calls C<schedule>, which has the effect of giving up the
184current "timeslice" to other coroutines of the same or higher priority. 226current "timeslice" to other coroutines of the same or higher priority.
185 227
186=cut
187
188=item terminate [arg...] 228=item terminate [arg...]
189 229
190Terminates the current process. 230Terminates the current coroutine with the given status values (see L<cancel>).
191
192Future versions of this function will allow result arguments.
193 231
194=cut 232=cut
195 233
196sub terminate { 234sub terminate {
197 $current->{status} = [@_];
198 $current->cancel; 235 $current->cancel (@_);
199 &schedule;
200 die; # NORETURN
201} 236}
202 237
203=back 238=back
204 239
205# dynamic methods 240# dynamic methods
206 241
207=head2 PROCESS METHODS 242=head2 COROUTINE METHODS
208 243
209These are the methods you can call on process objects. 244These are the methods you can call on coroutine objects.
210 245
211=over 4 246=over 4
212 247
213=item new Coro \&sub [, @args...] 248=item new Coro \&sub [, @args...]
214 249
215Create a new process and return it. When the sub returns the process 250Create a new coroutine and return it. When the sub returns the coroutine
216automatically terminates as if C<terminate> with the returned values were 251automatically terminates as if C<terminate> with the returned values were
217called. To make the process run you must first put it into the ready queue 252called. To make the coroutine run you must first put it into the ready queue
218by calling the ready method. 253by calling the ready method.
219 254
220=cut 255Calling C<exit> in a coroutine will not work correctly, so do not do that.
221 256
257=cut
258
222sub _newcoro { 259sub _run_coro {
223 terminate &{+shift}; 260 terminate &{+shift};
224} 261}
225 262
226sub new { 263sub new {
227 my $class = shift; 264 my $class = shift;
228 bless {
229 _coro_state => (new Coro::State $_[0] && \&_newcoro, @_),
230 }, $class;
231}
232 265
233=item $process->ready 266 $class->SUPER::new (\&_run_coro, @_)
267}
234 268
235Put the given process into the ready queue. 269=item $success = $coroutine->ready
236 270
237=cut 271Put the given coroutine into the ready queue (according to it's priority)
272and return true. If the coroutine is already in the ready queue, do nothing
273and return false.
238 274
239=item $process->cancel 275=item $is_ready = $coroutine->is_ready
240 276
241Like C<terminate>, but terminates the specified process instead. 277Return wether the coroutine is currently the ready queue or not,
278
279=item $coroutine->cancel (arg...)
280
281Terminates the given coroutine and makes it return the given arguments as
282status (default: the empty list).
242 283
243=cut 284=cut
244 285
245sub cancel { 286sub cancel {
287 my $self = shift;
288 $self->{status} = [@_];
246 push @destroy, $_[0]; 289 push @destroy, $self;
247 $manager->ready; 290 $manager->ready;
248 &schedule if $current == $_[0]; 291 &schedule if $current == $self;
249} 292}
250 293
251=item $process->join 294=item $coroutine->join
252 295
253Wait until the coroutine terminates and return any values given to the 296Wait until the coroutine terminates and return any values given to the
254C<terminate> function. C<join> can be called multiple times from multiple 297C<terminate> or C<cancel> functions. C<join> can be called multiple times
255processes. 298from multiple coroutine.
256 299
257=cut 300=cut
258 301
259sub join { 302sub join {
260 my $self = shift; 303 my $self = shift;
… …
263 &schedule; 306 &schedule;
264 } 307 }
265 wantarray ? @{$self->{status}} : $self->{status}[0]; 308 wantarray ? @{$self->{status}} : $self->{status}[0];
266} 309}
267 310
268=item $oldprio = $process->prio($newprio) 311=item $oldprio = $coroutine->prio ($newprio)
269 312
270Sets (or gets, if the argument is missing) the priority of the 313Sets (or gets, if the argument is missing) the priority of the
271process. Higher priority processes get run before lower priority 314coroutine. Higher priority coroutines get run before lower priority
272processes. Priorities are small signed integers (currently -4 .. +3), 315coroutines. Priorities are small signed integers (currently -4 .. +3),
273that you can refer to using PRIO_xxx constants (use the import tag :prio 316that you can refer to using PRIO_xxx constants (use the import tag :prio
274to get then): 317to get then):
275 318
276 PRIO_MAX > PRIO_HIGH > PRIO_NORMAL > PRIO_LOW > PRIO_IDLE > PRIO_MIN 319 PRIO_MAX > PRIO_HIGH > PRIO_NORMAL > PRIO_LOW > PRIO_IDLE > PRIO_MIN
277 3 > 1 > 0 > -1 > -3 > -4 320 3 > 1 > 0 > -1 > -3 > -4
… …
280 current->prio(PRIO_HIGH); 323 current->prio(PRIO_HIGH);
281 324
282The idle coroutine ($Coro::idle) always has a lower priority than any 325The idle coroutine ($Coro::idle) always has a lower priority than any
283existing coroutine. 326existing coroutine.
284 327
285Changing the priority of the current process will take effect immediately, 328Changing the priority of the current coroutine will take effect immediately,
286but changing the priority of processes in the ready queue (but not 329but changing the priority of coroutines in the ready queue (but not
287running) will only take effect after the next schedule (of that 330running) will only take effect after the next schedule (of that
288process). This is a bug that will be fixed in some future version. 331coroutine). This is a bug that will be fixed in some future version.
289 332
290=cut
291
292sub prio {
293 my $old = $_[0]{prio};
294 $_[0]{prio} = $_[1] if @_ > 1;
295 $old;
296}
297
298=item $newprio = $process->nice($change) 333=item $newprio = $coroutine->nice ($change)
299 334
300Similar to C<prio>, but subtract the given value from the priority (i.e. 335Similar to C<prio>, but subtract the given value from the priority (i.e.
301higher values mean lower priority, just as in unix). 336higher values mean lower priority, just as in unix).
302 337
303=cut
304
305sub nice {
306 $_[0]{prio} -= $_[1];
307}
308
309=item $olddesc = $process->desc($newdesc) 338=item $olddesc = $coroutine->desc ($newdesc)
310 339
311Sets (or gets in case the argument is missing) the description for this 340Sets (or gets in case the argument is missing) the description for this
312process. This is just a free-form string you can associate with a process. 341coroutine. This is just a free-form string you can associate with a coroutine.
313 342
314=cut 343=cut
315 344
316sub desc { 345sub desc {
317 my $old = $_[0]{desc}; 346 my $old = $_[0]{desc};
… …
319 $old; 348 $old;
320} 349}
321 350
322=back 351=back
323 352
353=head2 GLOBAL FUNCTIONS
354
355=over 4
356
357=item Coro::nready
358
359Returns the number of coroutines that are currently in the ready state,
360i.e. that can be swicthed to. The value C<0> means that the only runnable
361coroutine is the currently running one, so C<cede> would have no effect,
362and C<schedule> would cause a deadlock unless there is an idle handler
363that wakes up some coroutines.
364
365=item unblock_sub { ... }
366
367This utility function takes a BLOCK or code reference and "unblocks" it,
368returning the new coderef. This means that the new coderef will return
369immediately without blocking, returning nothing, while the original code
370ref will be called (with parameters) from within its own coroutine.
371
372The reason this fucntion exists is that many event libraries (such as the
373venerable L<Event|Event> module) are not coroutine-safe (a weaker form
374of thread-safety). This means you must not block within event callbacks,
375otherwise you might suffer from crashes or worse.
376
377This function allows your callbacks to block by executing them in another
378coroutine where it is safe to block. One example where blocking is handy
379is when you use the L<Coro::AIO|Coro::AIO> functions to save results to
380disk.
381
382In short: simply use C<unblock_sub { ... }> instead of C<sub { ... }> when
383creating event callbacks that want to block.
384
385=cut
386
387our @unblock_pool;
388our @unblock_queue;
389our $UNBLOCK_POOL_SIZE = 2;
390
391sub unblock_handler_ {
392 while () {
393 my ($cb, @arg) = @{ delete $Coro::current->{arg} };
394 $cb->(@arg);
395
396 last if @unblock_pool >= $UNBLOCK_POOL_SIZE;
397 push @unblock_pool, $Coro::current;
398 schedule;
399 }
400}
401
402our $unblock_scheduler = async {
403 while () {
404 while (my $cb = pop @unblock_queue) {
405 my $handler = (pop @unblock_pool or new Coro \&unblock_handler_);
406 $handler->{arg} = $cb;
407 $handler->ready;
408 cede;
409 }
410
411 schedule;
412 }
413};
414
415sub unblock_sub(&) {
416 my $cb = shift;
417
418 sub {
419 push @unblock_queue, [$cb, @_];
420 $unblock_scheduler->ready;
421 }
422}
423
424=back
425
324=cut 426=cut
325 427
3261; 4281;
327 429
328=head1 BUGS/LIMITATIONS 430=head1 BUGS/LIMITATIONS
… …
335 to allow per-thread schedulers, but Coro::State does not yet allow 437 to allow per-thread schedulers, but Coro::State does not yet allow
336 this). 438 this).
337 439
338=head1 SEE ALSO 440=head1 SEE ALSO
339 441
340L<Coro::Channel>, L<Coro::Cont>, L<Coro::Specific>, L<Coro::Semaphore>, 442Support/Utility: L<Coro::Cont>, L<Coro::Specific>, L<Coro::State>, L<Coro::Util>.
341L<Coro::Signal>, L<Coro::State>, L<Coro::Timer>, L<Coro::Event>, 443
342L<Coro::L<Coro::RWLock>, Handle>, L<Coro::Socket>. 444Locking/IPC: L<Coro::Signal>, L<Coro::Channel>, L<Coro::Semaphore>, L<Coro::SemaphoreSet>, L<Coro::RWLock>.
445
446Event/IO: L<Coro::Timer>, L<Coro::Event>, L<Coro::Handle>, L<Coro::Socket>, L<Coro::Select>.
447
448Embedding: L<Coro:MakeMaker>
343 449
344=head1 AUTHOR 450=head1 AUTHOR
345 451
346 Marc Lehmann <pcg@goof.com> 452 Marc Lehmann <schmorp@schmorp.de>
347 http://www.goof.com/pcg/marc/ 453 http://home.schmorp.de/
348 454
349=cut 455=cut
350 456

Diff Legend

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