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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.120 by root, Sat Dec 2 18:01:30 2006 UTC vs.
Revision 1.140 by root, Sat Jan 20 19:52:15 2007 UTC

4#include "perl.h" 4#include "perl.h"
5#include "XSUB.h" 5#include "XSUB.h"
6 6
7#include "patchlevel.h" 7#include "patchlevel.h"
8 8
9#if USE_VALGRIND
10# include <valgrind/valgrind.h>
11#endif
12
13/* the maximum number of idle cctx that will be pooled */
14#define MAX_IDLE_CCTX 8
15
16#define PERL_VERSION_ATLEAST(a,b,c) \
17 (PERL_REVISION > (a) \
18 || (PERL_REVISION == (a) \
19 && (PERL_VERSION > (b) \
20 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
21
22#if !PERL_VERSION_ATLEAST (5,6,0)
23# ifndef PL_ppaddr
24# define PL_ppaddr ppaddr
25# endif
26# ifndef call_sv
27# define call_sv perl_call_sv
28# endif
29# ifndef get_sv
30# define get_sv perl_get_sv
31# endif
32# ifndef get_cv
33# define get_cv perl_get_cv
34# endif
35# ifndef IS_PADGV
36# define IS_PADGV(v) 0
37# endif
38# ifndef IS_PADCONST
39# define IS_PADCONST(v) 0
40# endif
41#endif
42
43#include <stdio.h> 9#include <stdio.h>
44#include <errno.h> 10#include <errno.h>
45 11#include <assert.h>
46#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
47# undef STACKGUARD
48#endif
49
50#ifndef STACKGUARD
51# define STACKGUARD 0
52#endif
53 12
54#ifdef HAVE_MMAP 13#ifdef HAVE_MMAP
55# include <unistd.h> 14# include <unistd.h>
56# include <sys/mman.h> 15# include <sys/mman.h>
57# ifndef MAP_ANONYMOUS 16# ifndef MAP_ANONYMOUS
72#else 31#else
73# define PAGESIZE 0 32# define PAGESIZE 0
74# define BOOT_PAGESIZE (void)0 33# define BOOT_PAGESIZE (void)0
75#endif 34#endif
76 35
36#if USE_VALGRIND
37# include <valgrind/valgrind.h>
38#endif
39
40/* the maximum number of idle cctx that will be pooled */
41#define MAX_IDLE_CCTX 8
42
43#define PERL_VERSION_ATLEAST(a,b,c) \
44 (PERL_REVISION > (a) \
45 || (PERL_REVISION == (a) \
46 && (PERL_VERSION > (b) \
47 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
48
49#if !PERL_VERSION_ATLEAST (5,6,0)
50# ifndef PL_ppaddr
51# define PL_ppaddr ppaddr
52# endif
53# ifndef call_sv
54# define call_sv perl_call_sv
55# endif
56# ifndef get_sv
57# define get_sv perl_get_sv
58# endif
59# ifndef get_cv
60# define get_cv perl_get_cv
61# endif
62# ifndef IS_PADGV
63# define IS_PADGV(v) 0
64# endif
65# ifndef IS_PADCONST
66# define IS_PADCONST(v) 0
67# endif
68#endif
69
70/* 5.8.7 */
71#ifndef SvRV_set
72# define SvRV_set(s,v) SvRV(s) = (v)
73#endif
74
75#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
76# undef STACKGUARD
77#endif
78
79#ifndef STACKGUARD
80# define STACKGUARD 0
81#endif
82
83/* prefer perl internal functions over our own? */
84#ifndef PREFER_PERL_FUNCTIONS
85# define PREFER_PERL_FUNCTIONS 0
86#endif
87
77/* The next macro should declare a variable stacklevel that contains and approximation 88/* The next macro should declare a variable stacklevel that contains and approximation
78 * to the current C stack pointer. Its property is that it changes with each call 89 * to the current C stack pointer. Its property is that it changes with each call
79 * and should be unique. */ 90 * and should be unique. */
80#define dSTACKLEVEL int stacklevel 91#define dSTACKLEVEL int stacklevel
81#define STACKLEVEL ((void *)&stacklevel) 92#define STACKLEVEL ((void *)&stacklevel)
82 93
83#define IN_DESTRUCT (PL_main_cv == Nullcv) 94#define IN_DESTRUCT (PL_main_cv == Nullcv)
84 95
85#if __GNUC__ >= 3 96#if __GNUC__ >= 3
86# define attribute(x) __attribute__(x) 97# define attribute(x) __attribute__(x)
98# define BARRIER __asm__ __volatile__ ("" : : : "memory")
87#else 99#else
88# define attribute(x) 100# define attribute(x)
101# define BARRIER
89#endif 102#endif
90 103
91#define NOINLINE attribute ((noinline)) 104#define NOINLINE attribute ((noinline))
92 105
93#include "CoroAPI.h" 106#include "CoroAPI.h"
94
95#define TRANSFER_SET_STACKLEVEL 0x8bfbfbfb /* magic cookie */
96 107
97#ifdef USE_ITHREADS 108#ifdef USE_ITHREADS
98static perl_mutex coro_mutex; 109static perl_mutex coro_mutex;
99# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0) 110# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
100# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0) 111# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
101#else 112#else
102# define LOCK (void)0 113# define LOCK (void)0
103# define UNLOCK (void)0 114# define UNLOCK (void)0
104#endif 115#endif
105 116
117/* helper storage struct for Coro::AIO */
106struct io_state 118struct io_state
107{ 119{
108 int errorno; 120 int errorno;
109 I32 laststype; 121 I32 laststype;
110 int laststatval; 122 int laststatval;
126 /* the stack */ 138 /* the stack */
127 void *sptr; 139 void *sptr;
128 long ssize; /* positive == mmap, otherwise malloc */ 140 long ssize; /* positive == mmap, otherwise malloc */
129 141
130 /* cpu state */ 142 /* cpu state */
131 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 143 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
144 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
132 JMPENV *top_env; 145 JMPENV *top_env;
133 coro_context cctx; 146 coro_context cctx;
134 147
135 int inuse; 148 int inuse;
136 149
138 int valgrind_id; 151 int valgrind_id;
139#endif 152#endif
140} coro_cctx; 153} coro_cctx;
141 154
142enum { 155enum {
143 CF_RUNNING = 0x0001, /* coroutine is running */ 156 CF_RUNNING = 0x0001, /* coroutine is running */
144 CF_READY = 0x0002, /* coroutine is ready */ 157 CF_READY = 0x0002, /* coroutine is ready */
145 CF_NEW = 0x0004, /* ahs never been switched to */ 158 CF_NEW = 0x0004, /* has never been switched to */
159 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
146}; 160};
147 161
148/* this is a structure representing a perl-level coroutine */ 162/* this is a structure representing a perl-level coroutine */
149struct coro { 163struct coro {
150 /* the c coroutine allocated to this perl coroutine, if any */ 164 /* the c coroutine allocated to this perl coroutine, if any */
151 coro_cctx *cctx; 165 coro_cctx *cctx;
152 166
153 /* data associated with this coroutine (initial args) */ 167 /* data associated with this coroutine (initial args) */
154 AV *args; 168 AV *args;
155 int refcnt; 169 int refcnt;
156 int flags; 170 int save; /* CORO_SAVE flags */
171 int flags; /* CF_ flags */
157 172
158 /* optionally saved, might be zero */ 173 /* optionally saved, might be zero */
159 AV *defav; 174 AV *defav; /* @_ */
160 SV *defsv; 175 SV *defsv; /* $_ */
161 SV *errsv; 176 SV *errsv; /* $@ */
177 SV *irssv; /* $/ */
178 SV *irssv_sv; /* real $/ cache */
162 179
163#define VAR(name,type) type name; 180#define VAR(name,type) type name;
164# include "state.h" 181# include "state.h"
165#undef VAR 182#undef VAR
166 183
168 int prio; 185 int prio;
169}; 186};
170 187
171typedef struct coro *Coro__State; 188typedef struct coro *Coro__State;
172typedef struct coro *Coro__State_or_hashref; 189typedef struct coro *Coro__State_or_hashref;
190
191/** Coro ********************************************************************/
192
193#define PRIO_MAX 3
194#define PRIO_HIGH 1
195#define PRIO_NORMAL 0
196#define PRIO_LOW -1
197#define PRIO_IDLE -3
198#define PRIO_MIN -4
199
200/* for Coro.pm */
201static SV *coro_current;
202static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
203static int coro_nready;
204
205/** lowlevel stuff **********************************************************/
173 206
174static AV * 207static AV *
175coro_clone_padlist (CV *cv) 208coro_clone_padlist (CV *cv)
176{ 209{
177 AV *padlist = CvPADLIST (cv); 210 AV *padlist = CvPADLIST (cv);
252 285
253 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0) 286 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
254 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--]; 287 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
255 else 288 else
256 { 289 {
257#if 0 290#if PREFER_PERL_FUNCTIONS
258 /* this is probably cleaner, but also slower? */ 291 /* this is probably cleaner, but also slower? */
259 CV *cp = Perl_cv_clone (cv); 292 CV *cp = Perl_cv_clone (cv);
260 CvPADLIST (cv) = CvPADLIST (cp); 293 CvPADLIST (cv) = CvPADLIST (cp);
261 CvPADLIST (cp) = 0; 294 CvPADLIST (cp) = 0;
262 SvREFCNT_dec (cp); 295 SvREFCNT_dec (cp);
286 av_extend (av, AvMAX (av) + 1); 319 av_extend (av, AvMAX (av) + 1);
287 320
288 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); 321 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
289} 322}
290 323
324/** load & save, init *******************************************************/
325
291#define SB do { 326#define SB do {
292#define SE } while (0) 327#define SE } while (0)
293 328
294#define LOAD(state) load_state ((state))
295#define SAVE(state,flags) save_state ((state),(flags))
296
297#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE 329#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
298 330
299static void 331static void
300load_state (Coro__State c) 332load_perl (Coro__State c)
301{ 333{
302#define VAR(name,type) PL_ ## name = c->name; 334#define VAR(name,type) PL_ ## name = c->name;
303# include "state.h" 335# include "state.h"
304#undef VAR 336#undef VAR
305 337
306 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav); 338 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
307 if (c->defsv) REPLACE_SV (DEFSV , c->defsv); 339 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
308 if (c->errsv) REPLACE_SV (ERRSV , c->errsv); 340 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
341 if (c->irssv)
342 {
343 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
344 SvREFCNT_dec (c->irssv);
345 else
346 {
347 REPLACE_SV (PL_rs, c->irssv);
348 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
349 sv_setsv (c->irssv_sv, PL_rs);
350 }
351 }
309 352
310 { 353 {
311 dSP; 354 dSP;
312 CV *cv; 355 CV *cv;
313 356
322 PUTBACK; 365 PUTBACK;
323 } 366 }
324} 367}
325 368
326static void 369static void
327save_state (Coro__State c, int flags) 370save_perl (Coro__State c)
328{ 371{
329 { 372 {
330 dSP; 373 dSP;
331 I32 cxix = cxstack_ix; 374 I32 cxix = cxstack_ix;
332 PERL_CONTEXT *ccstk = cxstack; 375 PERL_CONTEXT *ccstk = cxstack;
335 /* 378 /*
336 * the worst thing you can imagine happens first - we have to save 379 * the worst thing you can imagine happens first - we have to save
337 * (and reinitialize) all cv's in the whole callchain :( 380 * (and reinitialize) all cv's in the whole callchain :(
338 */ 381 */
339 382
383 EXTEND (SP, 3 + 1);
340 PUSHs (Nullsv); 384 PUSHs (Nullsv);
341 /* this loop was inspired by pp_caller */ 385 /* this loop was inspired by pp_caller */
342 for (;;) 386 for (;;)
343 { 387 {
344 while (cxix >= 0) 388 while (cxix >= 0)
350 CV *cv = cx->blk_sub.cv; 394 CV *cv = cx->blk_sub.cv;
351 395
352 if (CvDEPTH (cv)) 396 if (CvDEPTH (cv))
353 { 397 {
354 EXTEND (SP, 3); 398 EXTEND (SP, 3);
355
356 PUSHs ((SV *)CvPADLIST (cv)); 399 PUSHs ((SV *)CvPADLIST (cv));
357 PUSHs (INT2PTR (SV *, CvDEPTH (cv))); 400 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
358 PUSHs ((SV *)cv); 401 PUSHs ((SV *)cv);
359 402
360 CvDEPTH (cv) = 0; 403 CvDEPTH (cv) = 0;
361 get_padlist (cv); 404 get_padlist (cv);
362 } 405 }
363 } 406 }
364#ifdef CXt_FORMAT
365 else if (CxTYPE (cx) == CXt_FORMAT)
366 {
367 /* I never used formats, so how should I know how these are implemented? */
368 /* my bold guess is as a simple, plain sub... */
369 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
370 }
371#endif
372 } 407 }
373 408
374 if (top_si->si_type == PERLSI_MAIN) 409 if (top_si->si_type == PERLSI_MAIN)
375 break; 410 break;
376 411
380 } 415 }
381 416
382 PUTBACK; 417 PUTBACK;
383 } 418 }
384 419
385 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0; 420 c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
386 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0; 421 c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
387 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0; 422 c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
423 c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
388 424
389#define VAR(name,type)c->name = PL_ ## name; 425#define VAR(name,type)c->name = PL_ ## name;
390# include "state.h" 426# include "state.h"
391#undef VAR 427#undef VAR
392} 428}
395 * allocate various perl stacks. This is an exact copy 431 * allocate various perl stacks. This is an exact copy
396 * of perl.c:init_stacks, except that it uses less memory 432 * of perl.c:init_stacks, except that it uses less memory
397 * on the (sometimes correct) assumption that coroutines do 433 * on the (sometimes correct) assumption that coroutines do
398 * not usually need a lot of stackspace. 434 * not usually need a lot of stackspace.
399 */ 435 */
436#if PREFER_PERL_FUNCTIONS
437# define coro_init_stacks init_stacks
438#else
400static void 439static void
401coro_init_stacks () 440coro_init_stacks ()
402{ 441{
403 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT)); 442 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
404 PL_curstackinfo->si_type = PERLSI_MAIN; 443 PL_curstackinfo->si_type = PERLSI_MAIN;
434 New(54,PL_retstack,16,OP*); 473 New(54,PL_retstack,16,OP*);
435 PL_retstack_ix = 0; 474 PL_retstack_ix = 0;
436 PL_retstack_max = 16; 475 PL_retstack_max = 16;
437#endif 476#endif
438} 477}
478#endif
439 479
440/* 480/*
441 * destroy the stacks, the callchain etc... 481 * destroy the stacks, the callchain etc...
442 */ 482 */
443static void 483static void
444coro_destroy_stacks () 484coro_destroy_stacks ()
445{ 485{
446 if (!IN_DESTRUCT) 486 if (!IN_DESTRUCT)
447 { 487 {
448 /* is this ugly, I ask? */ 488 /* restore all saved variables and stuff */
449 LEAVE_SCOPE (0); 489 LEAVE_SCOPE (0);
490 assert (PL_tmps_floor == -1);
450 491
451 /* sure it is, but more important: is it correct?? :/ */ 492 /* free all temporaries */
452 FREETMPS; 493 FREETMPS;
494 assert (PL_tmps_ix == -1);
453 495
496 /* unwind all extra stacks */
454 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/ 497 POPSTACK_TO (PL_mainstack);
498
499 /* unwind main stack */
500 dounwind (-1);
455 } 501 }
456 502
457 while (PL_curstackinfo->si_next) 503 while (PL_curstackinfo->si_next)
458 PL_curstackinfo = PL_curstackinfo->si_next; 504 PL_curstackinfo = PL_curstackinfo->si_next;
459 505
460 while (PL_curstackinfo) 506 while (PL_curstackinfo)
461 { 507 {
462 PERL_SI *p = PL_curstackinfo->si_prev; 508 PERL_SI *p = PL_curstackinfo->si_prev;
463 509
464 { /*D*//*remove*/
465 dSP;
466 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
467 PUTBACK; /* possibly superfluous */
468 }
469
470 if (!IN_DESTRUCT) 510 if (!IN_DESTRUCT)
471 {
472 dounwind (-1);/*D*//*remove*/
473 SvREFCNT_dec (PL_curstackinfo->si_stack); 511 SvREFCNT_dec (PL_curstackinfo->si_stack);
474 }
475 512
476 Safefree (PL_curstackinfo->si_cxstack); 513 Safefree (PL_curstackinfo->si_cxstack);
477 Safefree (PL_curstackinfo); 514 Safefree (PL_curstackinfo);
478 PL_curstackinfo = p; 515 PL_curstackinfo = p;
479 } 516 }
484 Safefree (PL_savestack); 521 Safefree (PL_savestack);
485#if !PERL_VERSION_ATLEAST (5,9,0) 522#if !PERL_VERSION_ATLEAST (5,9,0)
486 Safefree (PL_retstack); 523 Safefree (PL_retstack);
487#endif 524#endif
488} 525}
526
527/** coroutine stack handling ************************************************/
489 528
490static void 529static void
491setup_coro (struct coro *coro) 530setup_coro (struct coro *coro)
492{ 531{
493 /* 532 /*
583{ 622{
584 coro_cctx *cctx; 623 coro_cctx *cctx;
585 624
586 ++cctx_count; 625 ++cctx_count;
587 626
588 New (0, cctx, 1, coro_cctx); 627 Newz (0, cctx, 1, coro_cctx);
589 628
590#if HAVE_MMAP 629#if HAVE_MMAP
591 630
592 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; 631 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
593 /* mmap supposedly does allocate-on-write for us */ 632 /* mmap supposedly does allocate-on-write for us */
686 ++cctx_idle; 725 ++cctx_idle;
687 cctx->next = cctx_first; 726 cctx->next = cctx_first;
688 cctx_first = cctx; 727 cctx_first = cctx;
689} 728}
690 729
730/** coroutine switching *****************************************************/
731
691/* never call directly, always through the coro_state_transfer global variable */ 732/* never call directly, always through the coro_state_transfer global variable */
692static void NOINLINE 733static void NOINLINE
693transfer (struct coro *prev, struct coro *next, int flags) 734transfer (struct coro *prev, struct coro *next)
694{ 735{
695 dSTACKLEVEL; 736 dSTACKLEVEL;
696 737
697 /* sometimes transfer is only called to set idle_sp */ 738 /* sometimes transfer is only called to set idle_sp */
698 if (flags == TRANSFER_SET_STACKLEVEL) 739 if (!next)
740 {
699 ((coro_cctx *)prev)->idle_sp = STACKLEVEL; 741 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
742 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
743 }
700 else if (prev != next) 744 else if (prev != next)
701 { 745 {
702 coro_cctx *prev__cctx; 746 coro_cctx *prev__cctx;
703 747
704 if (prev->flags & CF_NEW) 748 if (prev->flags & CF_NEW)
715 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states"); 759 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
716 760
717 if (next->flags & CF_RUNNING) 761 if (next->flags & CF_RUNNING)
718 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states"); 762 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
719 763
764 if (next->flags & CF_DESTROYED)
765 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
766
720 prev->flags &= ~CF_RUNNING; 767 prev->flags &= ~CF_RUNNING;
721 next->flags |= CF_RUNNING; 768 next->flags |= CF_RUNNING;
722 769
723 LOCK; 770 LOCK;
724 771
725 if (next->flags & CF_NEW) 772 if (next->flags & CF_NEW)
726 { 773 {
727 /* need to start coroutine */ 774 /* need to start coroutine */
728 next->flags &= ~CF_NEW; 775 next->flags &= ~CF_NEW;
729 /* first get rid of the old state */ 776 /* first get rid of the old state */
730 SAVE (prev, -1); 777 save_perl (prev);
731 /* setup coroutine call */ 778 /* setup coroutine call */
732 setup_coro (next); 779 setup_coro (next);
733 /* need a new stack */ 780 /* need a new stack */
734 assert (!next->stack); 781 assert (!next->cctx);
735 } 782 }
736 else 783 else
737 { 784 {
738 /* coroutine already started */ 785 /* coroutine already started */
739 SAVE (prev, flags); 786 save_perl (prev);
740 LOAD (next); 787 load_perl (next);
741 } 788 }
742 789
743 prev__cctx = prev->cctx; 790 prev__cctx = prev->cctx;
744 791
745 /* possibly "free" the cctx */ 792 /* possibly "free" the cctx */
746 if (prev__cctx->idle_sp == STACKLEVEL) 793 if (prev__cctx->idle_sp == STACKLEVEL)
747 { 794 {
748 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */ 795 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
749 assert (PL_top_env == prev__cctx->top_env); 796 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
750 797
751 prev->cctx = 0; 798 prev->cctx = 0;
752 799
753 cctx_put (prev__cctx); 800 cctx_put (prev__cctx);
754 prev__cctx->inuse = 0; 801 prev__cctx->inuse = 0;
767 PL_top_env = next->cctx->top_env; 814 PL_top_env = next->cctx->top_env;
768 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx); 815 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
769 } 816 }
770 817
771 free_coro_mortal (); 818 free_coro_mortal ();
772
773 UNLOCK; 819 UNLOCK;
774 } 820 }
775} 821}
776 822
777struct transfer_args 823struct transfer_args
778{ 824{
779 struct coro *prev, *next; 825 struct coro *prev, *next;
780 int flags;
781}; 826};
782 827
783#define TRANSFER(ta) transfer ((ta).prev, (ta).next, (ta).flags) 828#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
784 829
830/** high level stuff ********************************************************/
831
785static void 832static int
786coro_state_destroy (struct coro *coro) 833coro_state_destroy (struct coro *coro)
787{ 834{
788 if (coro->refcnt--) 835 if (coro->flags & CF_DESTROYED)
789 return; 836 return 0;
837
838 coro->flags |= CF_DESTROYED;
839
840 if (coro->flags & CF_READY)
841 {
842 /* reduce nready, as destroying a ready coro effectively unreadies it */
843 /* alternative: look through all ready queues and remove the coro */
844 LOCK;
845 --coro_nready;
846 UNLOCK;
847 }
848 else
849 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
790 850
791 if (coro->mainstack && coro->mainstack != main_mainstack) 851 if (coro->mainstack && coro->mainstack != main_mainstack)
792 { 852 {
793 struct coro temp; 853 struct coro temp;
854
855 assert (!(coro->flags & CF_RUNNING));
856
857 Zero (&temp, 1, struct coro);
858 temp.save = CORO_SAVE_ALL;
794 859
795 if (coro->flags & CF_RUNNING) 860 if (coro->flags & CF_RUNNING)
796 croak ("FATAL: tried to destroy currently running coroutine"); 861 croak ("FATAL: tried to destroy currently running coroutine");
797 862
798 SAVE ((&temp), TRANSFER_SAVE_ALL); 863 save_perl (&temp);
799 LOAD (coro); 864 load_perl (coro);
800 865
801 coro_destroy_stacks (); 866 coro_destroy_stacks ();
802 867
803 LOAD ((&temp)); /* this will get rid of defsv etc.. */ 868 load_perl (&temp); /* this will get rid of defsv etc.. */
804 869
805 coro->mainstack = 0; 870 coro->mainstack = 0;
806 } 871 }
807 872
808 cctx_destroy (coro->cctx); 873 cctx_destroy (coro->cctx);
809 SvREFCNT_dec (coro->args); 874 SvREFCNT_dec (coro->args);
810 Safefree (coro); 875
876 return 1;
811} 877}
812 878
813static int 879static int
814coro_state_clear (pTHX_ SV *sv, MAGIC *mg) 880coro_state_free (pTHX_ SV *sv, MAGIC *mg)
815{ 881{
816 struct coro *coro = (struct coro *)mg->mg_ptr; 882 struct coro *coro = (struct coro *)mg->mg_ptr;
817 mg->mg_ptr = 0; 883 mg->mg_ptr = 0;
818 884
885 if (--coro->refcnt < 0)
886 {
819 coro_state_destroy (coro); 887 coro_state_destroy (coro);
888 Safefree (coro);
889 }
820 890
821 return 0; 891 return 0;
822} 892}
823 893
824static int 894static int
831 return 0; 901 return 0;
832} 902}
833 903
834static MGVTBL coro_state_vtbl = { 904static MGVTBL coro_state_vtbl = {
835 0, 0, 0, 0, 905 0, 0, 0, 0,
836 coro_state_clear, 906 coro_state_free,
837 0, 907 0,
838#ifdef MGf_DUP 908#ifdef MGf_DUP
839 coro_state_dup, 909 coro_state_dup,
840#else 910#else
841# define MGf_DUP 0 911# define MGf_DUP 0
863 assert (mg->mg_type == PERL_MAGIC_ext); 933 assert (mg->mg_type == PERL_MAGIC_ext);
864 return (struct coro *)mg->mg_ptr; 934 return (struct coro *)mg->mg_ptr;
865} 935}
866 936
867static void 937static void
868prepare_transfer (struct transfer_args *ta, SV *prev, SV *next, int flags) 938prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
869{ 939{
870 ta->prev = SvSTATE (prev); 940 ta->prev = SvSTATE (prev_sv);
871 ta->next = SvSTATE (next); 941 ta->next = SvSTATE (next_sv);
872 ta->flags = flags;
873} 942}
874 943
875static void 944static void
876api_transfer (SV *prev, SV *next, int flags) 945api_transfer (SV *prev_sv, SV *next_sv)
877{ 946{
878 struct transfer_args ta; 947 struct transfer_args ta;
879 948
880 prepare_transfer (&ta, prev, next, flags); 949 prepare_transfer (&ta, prev_sv, next_sv);
881 TRANSFER (ta); 950 TRANSFER (ta);
882} 951}
883 952
953static int
954api_save (SV *coro_sv, int new_save)
955{
956 struct coro *coro = SvSTATE (coro_sv);
957 int old_save = coro->save;
958
959 if (new_save >= 0)
960 coro->save = new_save;
961
962 return old_save;
963}
964
884/** Coro ********************************************************************/ 965/** Coro ********************************************************************/
885 966
886#define PRIO_MAX 3
887#define PRIO_HIGH 1
888#define PRIO_NORMAL 0
889#define PRIO_LOW -1
890#define PRIO_IDLE -3
891#define PRIO_MIN -4
892
893/* for Coro.pm */
894static SV *coro_current;
895static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
896static int coro_nready;
897
898static void 967static void
899coro_enq (SV *coro_sv) 968coro_enq (SV *coro_sv)
900{ 969{
901 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv); 970 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
902 coro_nready++;
903} 971}
904 972
905static SV * 973static SV *
906coro_deq (int min_prio) 974coro_deq (int min_prio)
907{ 975{
911 if (min_prio < 0) 979 if (min_prio < 0)
912 min_prio = 0; 980 min_prio = 0;
913 981
914 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; ) 982 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
915 if (AvFILLp (coro_ready [prio]) >= 0) 983 if (AvFILLp (coro_ready [prio]) >= 0)
916 {
917 coro_nready--;
918 return av_shift (coro_ready [prio]); 984 return av_shift (coro_ready [prio]);
919 }
920 985
921 return 0; 986 return 0;
922} 987}
923 988
924static int 989static int
932 coro = SvSTATE (coro_sv); 997 coro = SvSTATE (coro_sv);
933 998
934 if (coro->flags & CF_READY) 999 if (coro->flags & CF_READY)
935 return 0; 1000 return 0;
936 1001
937#if 0 /* this is actually harmless */
938 if (coro->flags & CF_RUNNING)
939 croak ("Coro::ready called on currently running coroutine");
940#endif
941
942 coro->flags |= CF_READY; 1002 coro->flags |= CF_READY;
943 1003
944 LOCK; 1004 LOCK;
945 coro_enq (SvREFCNT_inc (coro_sv)); 1005 coro_enq (SvREFCNT_inc (coro_sv));
1006 ++coro_nready;
946 UNLOCK; 1007 UNLOCK;
947 1008
948 return 1; 1009 return 1;
949} 1010}
950 1011
951static int 1012static int
952api_is_ready (SV *coro_sv) 1013api_is_ready (SV *coro_sv)
953{ 1014{
954 return !!SvSTATE (coro_sv)->flags & CF_READY; 1015 return !!(SvSTATE (coro_sv)->flags & CF_READY);
955} 1016}
956 1017
957static void 1018static void
958prepare_schedule (struct transfer_args *ta) 1019prepare_schedule (struct transfer_args *ta)
959{ 1020{
960 SV *prev, *next; 1021 SV *prev_sv, *next_sv;
961 1022
962 for (;;) 1023 for (;;)
963 { 1024 {
964 LOCK; 1025 LOCK;
965 next = coro_deq (PRIO_MIN); 1026 next_sv = coro_deq (PRIO_MIN);
1027
1028 /* nothing to schedule: call the idle handler */
1029 if (!next_sv)
1030 {
1031 dSP;
1032 UNLOCK;
1033
1034 ENTER;
1035 SAVETMPS;
1036
1037 PUSHMARK (SP);
1038 PUTBACK;
1039 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1040
1041 FREETMPS;
1042 LEAVE;
1043 continue;
1044 }
1045
1046 ta->next = SvSTATE (next_sv);
1047
1048 /* cannot transfer to destroyed coros, skip and look for next */
1049 if (ta->next->flags & CF_DESTROYED)
1050 {
1051 UNLOCK;
1052 SvREFCNT_dec (next_sv);
1053 /* coro_nready is already taken care of by destroy */
1054 continue;
1055 }
1056
1057 --coro_nready;
966 UNLOCK; 1058 UNLOCK;
967
968 if (next)
969 break; 1059 break;
970
971 {
972 dSP;
973
974 ENTER;
975 SAVETMPS;
976
977 PUSHMARK (SP);
978 PUTBACK;
979 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
980
981 FREETMPS;
982 LEAVE;
983 } 1060 }
984 }
985
986 prev = SvRV (coro_current);
987 SvRV_set (coro_current, next);
988 1061
989 /* free this only after the transfer */ 1062 /* free this only after the transfer */
1063 prev_sv = SvRV (coro_current);
1064 SvRV_set (coro_current, next_sv);
1065 ta->prev = SvSTATE (prev_sv);
1066
1067 assert (ta->next->flags & CF_READY);
1068 ta->next->flags &= ~CF_READY;
1069
990 LOCK; 1070 LOCK;
991 free_coro_mortal (); 1071 free_coro_mortal ();
1072 coro_mortal = prev_sv;
992 UNLOCK; 1073 UNLOCK;
993 coro_mortal = prev;
994
995 assert (!SvROK(prev));//D
996 assert (!SvROK(next));//D
997
998 ta->prev = SvSTATE (prev);
999 ta->next = SvSTATE (next);
1000 ta->flags = TRANSFER_SAVE_ALL;
1001
1002 assert (ta->flags & CF_READY);
1003 ta->next->flags &= ~CF_READY;
1004} 1074}
1005 1075
1006static void 1076static void
1007prepare_cede (struct transfer_args *ta) 1077prepare_cede (struct transfer_args *ta)
1008{ 1078{
1009 api_ready (coro_current); 1079 api_ready (coro_current);
1010
1011 prepare_schedule (ta); 1080 prepare_schedule (ta);
1081}
1082
1083static int
1084prepare_cede_notself (struct transfer_args *ta)
1085{
1086 if (coro_nready)
1087 {
1088 SV *prev = SvRV (coro_current);
1089 prepare_schedule (ta);
1090 api_ready (prev);
1091 return 1;
1092 }
1093 else
1094 return 0;
1012} 1095}
1013 1096
1014static void 1097static void
1015api_schedule (void) 1098api_schedule (void)
1016{ 1099{
1018 1101
1019 prepare_schedule (&ta); 1102 prepare_schedule (&ta);
1020 TRANSFER (ta); 1103 TRANSFER (ta);
1021} 1104}
1022 1105
1023static void 1106static int
1024api_cede (void) 1107api_cede (void)
1025{ 1108{
1026 struct transfer_args ta; 1109 struct transfer_args ta;
1027 1110
1028 prepare_cede (&ta); 1111 prepare_cede (&ta);
1112
1113 if (ta.prev != ta.next)
1114 {
1029 TRANSFER (ta); 1115 TRANSFER (ta);
1116 return 1;
1117 }
1118 else
1119 return 0;
1120}
1121
1122static int
1123api_cede_notself (void)
1124{
1125 struct transfer_args ta;
1126
1127 if (prepare_cede_notself (&ta))
1128 {
1129 TRANSFER (ta);
1130 return 1;
1131 }
1132 else
1133 return 0;
1030} 1134}
1031 1135
1032MODULE = Coro::State PACKAGE = Coro::State 1136MODULE = Coro::State PACKAGE = Coro::State
1033 1137
1034PROTOTYPES: DISABLE 1138PROTOTYPES: DISABLE
1040#endif 1144#endif
1041 BOOT_PAGESIZE; 1145 BOOT_PAGESIZE;
1042 1146
1043 coro_state_stash = gv_stashpv ("Coro::State", TRUE); 1147 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1044 1148
1045 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV)); 1149 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
1046 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV)); 1150 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
1047 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV)); 1151 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
1152 newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
1153 newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
1048 1154
1049 main_mainstack = PL_mainstack; 1155 main_mainstack = PL_mainstack;
1050 1156
1051 coroapi.ver = CORO_API_VERSION; 1157 coroapi.ver = CORO_API_VERSION;
1052 coroapi.transfer = api_transfer; 1158 coroapi.transfer = api_transfer;
1062 HV *hv; 1168 HV *hv;
1063 int i; 1169 int i;
1064 1170
1065 Newz (0, coro, 1, struct coro); 1171 Newz (0, coro, 1, struct coro);
1066 coro->args = newAV (); 1172 coro->args = newAV ();
1173 coro->save = CORO_SAVE_ALL;
1067 coro->flags = CF_NEW; 1174 coro->flags = CF_NEW;
1068 1175
1069 hv = newHV (); 1176 hv = newHV ();
1070 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP; 1177 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1071 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1)); 1178 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1072 1179
1073 for (i = 1; i < items; i++) 1180 for (i = 1; i < items; i++)
1074 av_push (coro->args, newSVsv (ST (i))); 1181 av_push (coro->args, newSVsv (ST (i)));
1075} 1182}
1076 OUTPUT: 1183 OUTPUT:
1184 RETVAL
1185
1186int
1187save (SV *coro, int new_save = -1)
1188 CODE:
1189 RETVAL = api_save (coro, new_save);
1190 OUTPUT:
1077 RETVAL 1191 RETVAL
1078 1192
1079void 1193void
1080_set_stacklevel (...) 1194_set_stacklevel (...)
1081 ALIAS: 1195 ALIAS:
1082 Coro::State::transfer = 1 1196 Coro::State::transfer = 1
1083 Coro::schedule = 2 1197 Coro::schedule = 2
1084 Coro::cede = 3 1198 Coro::cede = 3
1199 Coro::cede_notself = 4
1085 CODE: 1200 CODE:
1086{ 1201{
1087 struct transfer_args ta; 1202 struct transfer_args ta;
1088 1203
1089 switch (ix) 1204 switch (ix)
1090 { 1205 {
1091 case 0: 1206 case 0:
1092 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0))); 1207 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1093 ta.next = 0; 1208 ta.next = 0;
1094 ta.flags = TRANSFER_SET_STACKLEVEL;
1095 break; 1209 break;
1096 1210
1097 case 1: 1211 case 1:
1098 if (items != 3) 1212 if (items != 2)
1099 croak ("Coro::State::transfer (prev,next,flags) expects three arguments, not %d", items); 1213 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
1100 1214
1101 prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2))); 1215 prepare_transfer (&ta, ST (0), ST (1));
1102 break; 1216 break;
1103 1217
1104 case 2: 1218 case 2:
1105 prepare_schedule (&ta); 1219 prepare_schedule (&ta);
1106 break; 1220 break;
1107 1221
1108 case 3: 1222 case 3:
1109 prepare_cede (&ta); 1223 prepare_cede (&ta);
1110 break; 1224 break;
1225
1226 case 4:
1227 if (!prepare_cede_notself (&ta))
1228 XSRETURN_EMPTY;
1229
1230 break;
1111 } 1231 }
1112 1232
1233 BARRIER;
1113 TRANSFER (ta); 1234 TRANSFER (ta);
1114}
1115 1235
1116void 1236 if (GIMME_V != G_VOID && ta.next != ta.prev)
1117_clone_state_from (SV *dst, SV *src) 1237 XSRETURN_YES;
1238}
1239
1240bool
1241_destroy (SV *coro_sv)
1118 CODE: 1242 CODE:
1119{ 1243 RETVAL = coro_state_destroy (SvSTATE (coro_sv));
1120 struct coro *coro_src = SvSTATE (src); 1244 OUTPUT:
1121 1245 RETVAL
1122 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1123
1124 ++coro_src->refcnt;
1125 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1126}
1127 1246
1128void 1247void
1129_exit (code) 1248_exit (code)
1130 int code 1249 int code
1131 PROTOTYPE: $ 1250 PROTOTYPE: $
1168 coro_ready[i] = newAV (); 1287 coro_ready[i] = newAV ();
1169 1288
1170 { 1289 {
1171 SV *sv = perl_get_sv("Coro::API", 1); 1290 SV *sv = perl_get_sv("Coro::API", 1);
1172 1291
1173 coroapi.schedule = api_schedule; 1292 coroapi.schedule = api_schedule;
1293 coroapi.save = api_save;
1174 coroapi.cede = api_cede; 1294 coroapi.cede = api_cede;
1295 coroapi.cede_notself = api_cede_notself;
1175 coroapi.ready = api_ready; 1296 coroapi.ready = api_ready;
1176 coroapi.is_ready = api_is_ready; 1297 coroapi.is_ready = api_is_ready;
1177 coroapi.nready = &coro_nready; 1298 coroapi.nready = &coro_nready;
1178 coroapi.current = coro_current; 1299 coroapi.current = coro_current;
1179 1300
1180 GCoroAPI = &coroapi; 1301 GCoroAPI = &coroapi;
1181 sv_setiv (sv, (IV)&coroapi); 1302 sv_setiv (sv, (IV)&coroapi);
1182 SvREADONLY_on (sv); 1303 SvREADONLY_on (sv);
1183 } 1304 }
1184} 1305}
1306
1307void
1308_set_current (SV *current)
1309 PROTOTYPE: $
1310 CODE:
1311 SvREFCNT_dec (SvRV (coro_current));
1312 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1185 1313
1186int 1314int
1187prio (Coro::State coro, int newprio = 0) 1315prio (Coro::State coro, int newprio = 0)
1188 ALIAS: 1316 ALIAS:
1189 nice = 1 1317 nice = 1
1192 RETVAL = coro->prio; 1320 RETVAL = coro->prio;
1193 1321
1194 if (items > 1) 1322 if (items > 1)
1195 { 1323 {
1196 if (ix) 1324 if (ix)
1197 newprio += coro->prio; 1325 newprio = coro->prio - newprio;
1198 1326
1199 if (newprio < PRIO_MIN) newprio = PRIO_MIN; 1327 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1200 if (newprio > PRIO_MAX) newprio = PRIO_MAX; 1328 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1201 1329
1202 coro->prio = newprio; 1330 coro->prio = newprio;
1203 } 1331 }
1204} 1332}
1333 OUTPUT:
1334 RETVAL
1205 1335
1206SV * 1336SV *
1207ready (SV *self) 1337ready (SV *self)
1208 PROTOTYPE: $ 1338 PROTOTYPE: $
1209 CODE: 1339 CODE:
1225 CODE: 1355 CODE:
1226 RETVAL = coro_nready; 1356 RETVAL = coro_nready;
1227 OUTPUT: 1357 OUTPUT:
1228 RETVAL 1358 RETVAL
1229 1359
1230void
1231_set_current (SV *current)
1232 PROTOTYPE: $
1233 CODE:
1234 SvREFCNT_dec (SvRV (coro_current));
1235 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1236
1237MODULE = Coro::State PACKAGE = Coro::AIO 1360MODULE = Coro::State PACKAGE = Coro::AIO
1238 1361
1239SV * 1362SV *
1240_get_state () 1363_get_state ()
1241 CODE: 1364 CODE:
1242{ 1365{
1366 struct io_state *data;
1367
1243 RETVAL = newSV (sizeof (struct io_state)); 1368 RETVAL = newSV (sizeof (struct io_state));
1244 struct io_state *data = (struct io_state *)SvPVX (RETVAL); 1369 data = (struct io_state *)SvPVX (RETVAL);
1245 SvCUR_set (RETVAL, sizeof (struct io_state)); 1370 SvCUR_set (RETVAL, sizeof (struct io_state));
1246 SvPOK_only (RETVAL); 1371 SvPOK_only (RETVAL);
1247 1372
1248 data->errorno = errno; 1373 data->errorno = errno;
1249 data->laststype = PL_laststype; 1374 data->laststype = PL_laststype;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines