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.122 by root, Mon Dec 4 13:47:56 2006 UTC vs.
Revision 1.142 by root, Tue Feb 13 19:21:29 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# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
39#else
40# define REGISTER_STACK(cctx,start,end)
41#endif
42
43/* the maximum number of idle cctx that will be pooled */
44#define MAX_IDLE_CCTX 8
45
46#define PERL_VERSION_ATLEAST(a,b,c) \
47 (PERL_REVISION > (a) \
48 || (PERL_REVISION == (a) \
49 && (PERL_VERSION > (b) \
50 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
51
52#if !PERL_VERSION_ATLEAST (5,6,0)
53# ifndef PL_ppaddr
54# define PL_ppaddr ppaddr
55# endif
56# ifndef call_sv
57# define call_sv perl_call_sv
58# endif
59# ifndef get_sv
60# define get_sv perl_get_sv
61# endif
62# ifndef get_cv
63# define get_cv perl_get_cv
64# endif
65# ifndef IS_PADGV
66# define IS_PADGV(v) 0
67# endif
68# ifndef IS_PADCONST
69# define IS_PADCONST(v) 0
70# endif
71#endif
72
73/* 5.8.7 */
74#ifndef SvRV_set
75# define SvRV_set(s,v) SvRV(s) = (v)
76#endif
77
78#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
79# undef STACKGUARD
80#endif
81
82#ifndef STACKGUARD
83# define STACKGUARD 0
84#endif
85
86/* prefer perl internal functions over our own? */
87#ifndef PREFER_PERL_FUNCTIONS
88# define PREFER_PERL_FUNCTIONS 0
89#endif
90
77/* The next macro should declare a variable stacklevel that contains and approximation 91/* 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 92 * to the current C stack pointer. Its property is that it changes with each call
79 * and should be unique. */ 93 * and should be unique. */
80#define dSTACKLEVEL int stacklevel 94#define dSTACKLEVEL int stacklevel
81#define STACKLEVEL ((void *)&stacklevel) 95#define STACKLEVEL ((void *)&stacklevel)
82 96
83#define IN_DESTRUCT (PL_main_cv == Nullcv) 97#define IN_DESTRUCT (PL_main_cv == Nullcv)
84 98
85#if __GNUC__ >= 3 99#if __GNUC__ >= 3
86# define attribute(x) __attribute__(x) 100# define attribute(x) __attribute__(x)
101# define BARRIER __asm__ __volatile__ ("" : : : "memory")
87#else 102#else
88# define attribute(x) 103# define attribute(x)
104# define BARRIER
89#endif 105#endif
90 106
91#define NOINLINE attribute ((noinline)) 107#define NOINLINE attribute ((noinline))
92 108
93#include "CoroAPI.h" 109#include "CoroAPI.h"
… …
99#else 115#else
100# define LOCK (void)0 116# define LOCK (void)0
101# define UNLOCK (void)0 117# define UNLOCK (void)0
102#endif 118#endif
103 119
120/* helper storage struct for Coro::AIO */
104struct io_state 121struct io_state
105{ 122{
106 int errorno; 123 int errorno;
107 I32 laststype; 124 I32 laststype;
108 int laststatval; 125 int laststatval;
… …
121typedef struct coro_cctx { 138typedef struct coro_cctx {
122 struct coro_cctx *next; 139 struct coro_cctx *next;
123 140
124 /* the stack */ 141 /* the stack */
125 void *sptr; 142 void *sptr;
126 long ssize; /* positive == mmap, otherwise malloc */ 143 ssize_t ssize; /* positive == mmap, otherwise malloc */
127 144
128 /* cpu state */ 145 /* cpu state */
129 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 146 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
147 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
130 JMPENV *top_env; 148 JMPENV *top_env;
131 coro_context cctx; 149 coro_context cctx;
132 150
133 int inuse; 151 int inuse;
134 152
… …
136 int valgrind_id; 154 int valgrind_id;
137#endif 155#endif
138} coro_cctx; 156} coro_cctx;
139 157
140enum { 158enum {
141 CF_RUNNING = 0x0001, /* coroutine is running */ 159 CF_RUNNING = 0x0001, /* coroutine is running */
142 CF_READY = 0x0002, /* coroutine is ready */ 160 CF_READY = 0x0002, /* coroutine is ready */
143 CF_NEW = 0x0004, /* ahs never been switched to */ 161 CF_NEW = 0x0004, /* has never been switched to */
162 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
144}; 163};
145 164
146/* this is a structure representing a perl-level coroutine */ 165/* this is a structure representing a perl-level coroutine */
147struct coro { 166struct coro {
148 /* the c coroutine allocated to this perl coroutine, if any */ 167 /* the c coroutine allocated to this perl coroutine, if any */
… …
157 /* optionally saved, might be zero */ 176 /* optionally saved, might be zero */
158 AV *defav; /* @_ */ 177 AV *defav; /* @_ */
159 SV *defsv; /* $_ */ 178 SV *defsv; /* $_ */
160 SV *errsv; /* $@ */ 179 SV *errsv; /* $@ */
161 SV *irssv; /* $/ */ 180 SV *irssv; /* $/ */
181 SV *irssv_sv; /* real $/ cache */
162 182
163#define VAR(name,type) type name; 183#define VAR(name,type) type name;
164# include "state.h" 184# include "state.h"
165#undef VAR 185#undef VAR
166 186
… …
168 int prio; 188 int prio;
169}; 189};
170 190
171typedef struct coro *Coro__State; 191typedef struct coro *Coro__State;
172typedef struct coro *Coro__State_or_hashref; 192typedef struct coro *Coro__State_or_hashref;
193
194/** Coro ********************************************************************/
195
196#define PRIO_MAX 3
197#define PRIO_HIGH 1
198#define PRIO_NORMAL 0
199#define PRIO_LOW -1
200#define PRIO_IDLE -3
201#define PRIO_MIN -4
202
203/* for Coro.pm */
204static SV *coro_current;
205static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
206static int coro_nready;
207
208/** lowlevel stuff **********************************************************/
173 209
174static AV * 210static AV *
175coro_clone_padlist (CV *cv) 211coro_clone_padlist (CV *cv)
176{ 212{
177 AV *padlist = CvPADLIST (cv); 213 AV *padlist = CvPADLIST (cv);
… …
252 288
253 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0) 289 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
254 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--]; 290 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
255 else 291 else
256 { 292 {
257#if 0 293#if PREFER_PERL_FUNCTIONS
258 /* this is probably cleaner, but also slower? */ 294 /* this is probably cleaner, but also slower? */
259 CV *cp = Perl_cv_clone (cv); 295 CV *cp = Perl_cv_clone (cv);
260 CvPADLIST (cv) = CvPADLIST (cp); 296 CvPADLIST (cv) = CvPADLIST (cp);
261 CvPADLIST (cp) = 0; 297 CvPADLIST (cp) = 0;
262 SvREFCNT_dec (cp); 298 SvREFCNT_dec (cp);
… …
286 av_extend (av, AvMAX (av) + 1); 322 av_extend (av, AvMAX (av) + 1);
287 323
288 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); 324 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
289} 325}
290 326
327/** load & save, init *******************************************************/
328
291#define SB do { 329#define SB do {
292#define SE } while (0) 330#define SE } while (0)
293 331
294#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE 332#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
295 333
… …
301#undef VAR 339#undef VAR
302 340
303 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav); 341 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
304 if (c->defsv) REPLACE_SV (DEFSV , c->defsv); 342 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
305 if (c->errsv) REPLACE_SV (ERRSV , c->errsv); 343 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
306 if (c->irssv) REPLACE_SV (PL_rs , c->irssv); 344 if (c->irssv)
345 {
346 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
347 SvREFCNT_dec (c->irssv);
348 else
349 {
350 REPLACE_SV (PL_rs, c->irssv);
351 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
352 sv_setsv (c->irssv_sv, PL_rs);
353 }
354 }
307 355
308 { 356 {
309 dSP; 357 dSP;
310 CV *cv; 358 CV *cv;
311 359
… …
317 CvPADLIST (cv) = (AV *)POPs; 365 CvPADLIST (cv) = (AV *)POPs;
318 } 366 }
319 367
320 PUTBACK; 368 PUTBACK;
321 } 369 }
370 assert (!PL_comppad || AvARRAY (PL_comppad));//D
322} 371}
323 372
324static void 373static void
325save_perl (Coro__State c) 374save_perl (Coro__State c)
326{ 375{
376 assert (!PL_comppad || AvARRAY (PL_comppad));//D
327 { 377 {
328 dSP; 378 dSP;
329 I32 cxix = cxstack_ix; 379 I32 cxix = cxstack_ix;
330 PERL_CONTEXT *ccstk = cxstack; 380 PERL_CONTEXT *ccstk = cxstack;
331 PERL_SI *top_si = PL_curstackinfo; 381 PERL_SI *top_si = PL_curstackinfo;
… …
333 /* 383 /*
334 * the worst thing you can imagine happens first - we have to save 384 * the worst thing you can imagine happens first - we have to save
335 * (and reinitialize) all cv's in the whole callchain :( 385 * (and reinitialize) all cv's in the whole callchain :(
336 */ 386 */
337 387
388 EXTEND (SP, 3 + 1);
338 PUSHs (Nullsv); 389 PUSHs (Nullsv);
339 /* this loop was inspired by pp_caller */ 390 /* this loop was inspired by pp_caller */
340 for (;;) 391 for (;;)
341 { 392 {
342 while (cxix >= 0) 393 while (cxix >= 0)
… …
348 CV *cv = cx->blk_sub.cv; 399 CV *cv = cx->blk_sub.cv;
349 400
350 if (CvDEPTH (cv)) 401 if (CvDEPTH (cv))
351 { 402 {
352 EXTEND (SP, 3); 403 EXTEND (SP, 3);
353
354 PUSHs ((SV *)CvPADLIST (cv)); 404 PUSHs ((SV *)CvPADLIST (cv));
355 PUSHs (INT2PTR (SV *, CvDEPTH (cv))); 405 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
356 PUSHs ((SV *)cv); 406 PUSHs ((SV *)cv);
357 407
358 CvDEPTH (cv) = 0; 408 CvDEPTH (cv) = 0;
359 get_padlist (cv); 409 get_padlist (cv);
360 } 410 }
361 } 411 }
362#ifdef CXt_FORMAT
363 else if (CxTYPE (cx) == CXt_FORMAT)
364 {
365 /* I never used formats, so how should I know how these are implemented? */
366 /* my bold guess is as a simple, plain sub... */
367 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
368 }
369#endif
370 } 412 }
371 413
372 if (top_si->si_type == PERLSI_MAIN) 414 if (top_si->si_type == PERLSI_MAIN)
373 break; 415 break;
374 416
… …
394 * allocate various perl stacks. This is an exact copy 436 * allocate various perl stacks. This is an exact copy
395 * of perl.c:init_stacks, except that it uses less memory 437 * of perl.c:init_stacks, except that it uses less memory
396 * on the (sometimes correct) assumption that coroutines do 438 * on the (sometimes correct) assumption that coroutines do
397 * not usually need a lot of stackspace. 439 * not usually need a lot of stackspace.
398 */ 440 */
441#if PREFER_PERL_FUNCTIONS
442# define coro_init_stacks init_stacks
443#else
399static void 444static void
400coro_init_stacks () 445coro_init_stacks ()
401{ 446{
402 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT)); 447 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
403 PL_curstackinfo->si_type = PERLSI_MAIN; 448 PL_curstackinfo->si_type = PERLSI_MAIN;
… …
433 New(54,PL_retstack,16,OP*); 478 New(54,PL_retstack,16,OP*);
434 PL_retstack_ix = 0; 479 PL_retstack_ix = 0;
435 PL_retstack_max = 16; 480 PL_retstack_max = 16;
436#endif 481#endif
437} 482}
483#endif
438 484
439/* 485/*
440 * destroy the stacks, the callchain etc... 486 * destroy the stacks, the callchain etc...
441 */ 487 */
442static void 488static void
443coro_destroy_stacks () 489coro_destroy_stacks ()
444{ 490{
445 if (!IN_DESTRUCT) 491 if (!IN_DESTRUCT)
446 { 492 {
447 /* is this ugly, I ask? */ 493 /* restore all saved variables and stuff */
448 LEAVE_SCOPE (0); 494 LEAVE_SCOPE (0);
495 assert (PL_tmps_floor == -1);
449 496
450 /* sure it is, but more important: is it correct?? :/ */ 497 /* free all temporaries */
451 FREETMPS; 498 FREETMPS;
499 assert (PL_tmps_ix == -1);
452 500
501 /* unwind all extra stacks */
453 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/ 502 POPSTACK_TO (PL_mainstack);
503
504 /* unwind main stack */
505 dounwind (-1);
454 } 506 }
455 507
456 while (PL_curstackinfo->si_next) 508 while (PL_curstackinfo->si_next)
457 PL_curstackinfo = PL_curstackinfo->si_next; 509 PL_curstackinfo = PL_curstackinfo->si_next;
458 510
459 while (PL_curstackinfo) 511 while (PL_curstackinfo)
460 { 512 {
461 PERL_SI *p = PL_curstackinfo->si_prev; 513 PERL_SI *p = PL_curstackinfo->si_prev;
462 514
463 { /*D*//*remove*/
464 dSP;
465 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
466 PUTBACK; /* possibly superfluous */
467 }
468
469 if (!IN_DESTRUCT) 515 if (!IN_DESTRUCT)
470 {
471 dounwind (-1);/*D*//*remove*/
472 SvREFCNT_dec (PL_curstackinfo->si_stack); 516 SvREFCNT_dec (PL_curstackinfo->si_stack);
473 }
474 517
475 Safefree (PL_curstackinfo->si_cxstack); 518 Safefree (PL_curstackinfo->si_cxstack);
476 Safefree (PL_curstackinfo); 519 Safefree (PL_curstackinfo);
477 PL_curstackinfo = p; 520 PL_curstackinfo = p;
478 } 521 }
… …
484#if !PERL_VERSION_ATLEAST (5,9,0) 527#if !PERL_VERSION_ATLEAST (5,9,0)
485 Safefree (PL_retstack); 528 Safefree (PL_retstack);
486#endif 529#endif
487} 530}
488 531
532/** coroutine stack handling ************************************************/
533
489static void 534static void
490setup_coro (struct coro *coro) 535setup_coro (struct coro *coro)
491{ 536{
492 /* 537 /*
493 * emulate part of the perl startup here. 538 * emulate part of the perl startup here.
… …
495 540
496 coro_init_stacks (); 541 coro_init_stacks ();
497 542
498 PL_curcop = &PL_compiling; 543 PL_curcop = &PL_compiling;
499 PL_in_eval = EVAL_NULL; 544 PL_in_eval = EVAL_NULL;
545 PL_comppad = 0;
500 PL_curpm = 0; 546 PL_curpm = 0;
501 PL_localizing = 0; 547 PL_localizing = 0;
502 PL_dirty = 0; 548 PL_dirty = 0;
503 PL_restartop = 0; 549 PL_restartop = 0;
504 550
… …
582{ 628{
583 coro_cctx *cctx; 629 coro_cctx *cctx;
584 630
585 ++cctx_count; 631 ++cctx_count;
586 632
587 New (0, cctx, 1, coro_cctx); 633 Newz (0, cctx, 1, coro_cctx);
588 634
589#if HAVE_MMAP 635#if HAVE_MMAP
590 636
591 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; 637 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
592 /* mmap supposedly does allocate-on-write for us */ 638 /* mmap supposedly does allocate-on-write for us */
593 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); 639 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
594 640
595 if (cctx->sptr == (void *)-1) 641 if (cctx->sptr != (void *)-1)
596 {
597 perror ("FATAL: unable to mmap stack for coroutine");
598 _exit (EXIT_FAILURE);
599 } 642 {
600
601# if STACKGUARD 643# if STACKGUARD
602 mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE); 644 mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
603# endif 645# endif
604 646 REGISTER_STACK (
605#else 647 cctx,
606
607 cctx->ssize = STACKSIZE * (long)sizeof (long);
608 New (0, cctx->sptr, STACKSIZE, long);
609
610 if (!cctx->sptr)
611 {
612 perror ("FATAL: unable to malloc stack for coroutine");
613 _exit (EXIT_FAILURE);
614 }
615
616#endif
617
618#if USE_VALGRIND
619 cctx->valgrind_id = VALGRIND_STACK_REGISTER (
620 STACKGUARD * PAGESIZE + (char *)cctx->sptr, 648 STACKGUARD * PAGESIZE + (char *)cctx->sptr,
621 cctx->ssize + (char *)cctx->sptr 649 cctx->ssize + (char *)cctx->sptr
622 ); 650 );
623#endif
624 651
625 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize); 652 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
653 }
654 else
655#endif
656 {
657 cctx->ssize = -STACKSIZE * (long)sizeof (long);
658 New (0, cctx->sptr, STACKSIZE, long);
659
660 if (!cctx->sptr)
661 {
662 perror ("FATAL: unable to allocate stack for coroutine");
663 _exit (EXIT_FAILURE);
664 }
665
666 REGISTER_STACK (
667 cctx,
668 (char *)cctx->sptr,
669 (char *)cctx->sptr - cctx->ssize
670 );
671
672 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, -cctx->ssize);
673 }
626 674
627 return cctx; 675 return cctx;
628} 676}
629 677
630static void 678static void
… …
638#if USE_VALGRIND 686#if USE_VALGRIND
639 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id); 687 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
640#endif 688#endif
641 689
642#if HAVE_MMAP 690#if HAVE_MMAP
691 if (cctx->ssize > 0)
643 munmap (cctx->sptr, cctx->ssize); 692 munmap (cctx->sptr, cctx->ssize);
644#else 693 else
694#endif
645 Safefree (cctx->sptr); 695 Safefree (cctx->sptr);
646#endif
647 696
648 Safefree (cctx); 697 Safefree (cctx);
649} 698}
650 699
651static coro_cctx * 700static coro_cctx *
… …
685 ++cctx_idle; 734 ++cctx_idle;
686 cctx->next = cctx_first; 735 cctx->next = cctx_first;
687 cctx_first = cctx; 736 cctx_first = cctx;
688} 737}
689 738
739/** coroutine switching *****************************************************/
740
690/* never call directly, always through the coro_state_transfer global variable */ 741/* never call directly, always through the coro_state_transfer global variable */
691static void NOINLINE 742static void NOINLINE
692transfer (struct coro *prev, struct coro *next) 743transfer (struct coro *prev, struct coro *next)
693{ 744{
694 dSTACKLEVEL; 745 dSTACKLEVEL;
695 746
696 /* sometimes transfer is only called to set idle_sp */ 747 /* sometimes transfer is only called to set idle_sp */
697 if (!next) 748 if (!next)
749 {
698 ((coro_cctx *)prev)->idle_sp = STACKLEVEL; 750 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
751 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
752 }
699 else if (prev != next) 753 else if (prev != next)
700 { 754 {
701 coro_cctx *prev__cctx; 755 coro_cctx *prev__cctx;
702 756
703 if (prev->flags & CF_NEW) 757 if (prev->flags & CF_NEW)
… …
713 if (!prev->flags & CF_RUNNING) 767 if (!prev->flags & CF_RUNNING)
714 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states"); 768 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
715 769
716 if (next->flags & CF_RUNNING) 770 if (next->flags & CF_RUNNING)
717 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states"); 771 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
772
773 if (next->flags & CF_DESTROYED)
774 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
718 775
719 prev->flags &= ~CF_RUNNING; 776 prev->flags &= ~CF_RUNNING;
720 next->flags |= CF_RUNNING; 777 next->flags |= CF_RUNNING;
721 778
722 LOCK; 779 LOCK;
… …
728 /* first get rid of the old state */ 785 /* first get rid of the old state */
729 save_perl (prev); 786 save_perl (prev);
730 /* setup coroutine call */ 787 /* setup coroutine call */
731 setup_coro (next); 788 setup_coro (next);
732 /* need a new stack */ 789 /* need a new stack */
733 assert (!next->stack); 790 assert (!next->cctx);
734 } 791 }
735 else 792 else
736 { 793 {
737 /* coroutine already started */ 794 /* coroutine already started */
738 save_perl (prev); 795 save_perl (prev);
… …
743 800
744 /* possibly "free" the cctx */ 801 /* possibly "free" the cctx */
745 if (prev__cctx->idle_sp == STACKLEVEL) 802 if (prev__cctx->idle_sp == STACKLEVEL)
746 { 803 {
747 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */ 804 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
748 assert (PL_top_env == prev__cctx->top_env); 805 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
749 806
750 prev->cctx = 0; 807 prev->cctx = 0;
751 808
752 cctx_put (prev__cctx); 809 cctx_put (prev__cctx);
753 prev__cctx->inuse = 0; 810 prev__cctx->inuse = 0;
… …
766 PL_top_env = next->cctx->top_env; 823 PL_top_env = next->cctx->top_env;
767 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx); 824 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
768 } 825 }
769 826
770 free_coro_mortal (); 827 free_coro_mortal ();
771
772 UNLOCK; 828 UNLOCK;
773 } 829 }
774} 830}
775 831
776struct transfer_args 832struct transfer_args
… …
778 struct coro *prev, *next; 834 struct coro *prev, *next;
779}; 835};
780 836
781#define TRANSFER(ta) transfer ((ta).prev, (ta).next) 837#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
782 838
839/** high level stuff ********************************************************/
840
783static void 841static int
784coro_state_destroy (struct coro *coro) 842coro_state_destroy (struct coro *coro)
785{ 843{
786 if (coro->refcnt--) 844 if (coro->flags & CF_DESTROYED)
787 return; 845 return 0;
846
847 coro->flags |= CF_DESTROYED;
848
849 if (coro->flags & CF_READY)
850 {
851 /* reduce nready, as destroying a ready coro effectively unreadies it */
852 /* alternative: look through all ready queues and remove the coro */
853 LOCK;
854 --coro_nready;
855 UNLOCK;
856 }
857 else
858 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
788 859
789 if (coro->mainstack && coro->mainstack != main_mainstack) 860 if (coro->mainstack && coro->mainstack != main_mainstack)
790 { 861 {
791 struct coro temp; 862 struct coro temp;
863
864 assert (!(coro->flags & CF_RUNNING));
865
792 Zero (&temp, 1, struct coro); 866 Zero (&temp, 1, struct coro);
793 temp.save = CORO_SAVE_ALL; 867 temp.save = CORO_SAVE_ALL;
794 868
795 if (coro->flags & CF_RUNNING) 869 if (coro->flags & CF_RUNNING)
796 croak ("FATAL: tried to destroy currently running coroutine"); 870 croak ("FATAL: tried to destroy currently running coroutine");
… …
805 coro->mainstack = 0; 879 coro->mainstack = 0;
806 } 880 }
807 881
808 cctx_destroy (coro->cctx); 882 cctx_destroy (coro->cctx);
809 SvREFCNT_dec (coro->args); 883 SvREFCNT_dec (coro->args);
810 Safefree (coro); 884
885 return 1;
811} 886}
812 887
813static int 888static int
814coro_state_clear (pTHX_ SV *sv, MAGIC *mg) 889coro_state_free (pTHX_ SV *sv, MAGIC *mg)
815{ 890{
816 struct coro *coro = (struct coro *)mg->mg_ptr; 891 struct coro *coro = (struct coro *)mg->mg_ptr;
817 mg->mg_ptr = 0; 892 mg->mg_ptr = 0;
818 893
894 if (--coro->refcnt < 0)
895 {
819 coro_state_destroy (coro); 896 coro_state_destroy (coro);
897 Safefree (coro);
898 }
820 899
821 return 0; 900 return 0;
822} 901}
823 902
824static int 903static int
… …
831 return 0; 910 return 0;
832} 911}
833 912
834static MGVTBL coro_state_vtbl = { 913static MGVTBL coro_state_vtbl = {
835 0, 0, 0, 0, 914 0, 0, 0, 0,
836 coro_state_clear, 915 coro_state_free,
837 0, 916 0,
838#ifdef MGf_DUP 917#ifdef MGf_DUP
839 coro_state_dup, 918 coro_state_dup,
840#else 919#else
841# define MGf_DUP 0 920# define MGf_DUP 0
… …
892 return old_save; 971 return old_save;
893} 972}
894 973
895/** Coro ********************************************************************/ 974/** Coro ********************************************************************/
896 975
897#define PRIO_MAX 3
898#define PRIO_HIGH 1
899#define PRIO_NORMAL 0
900#define PRIO_LOW -1
901#define PRIO_IDLE -3
902#define PRIO_MIN -4
903
904/* for Coro.pm */
905static SV *coro_current;
906static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
907static int coro_nready;
908
909static void 976static void
910coro_enq (SV *coro_sv) 977coro_enq (SV *coro_sv)
911{ 978{
912 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv); 979 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
913 coro_nready++;
914} 980}
915 981
916static SV * 982static SV *
917coro_deq (int min_prio) 983coro_deq (int min_prio)
918{ 984{
… …
922 if (min_prio < 0) 988 if (min_prio < 0)
923 min_prio = 0; 989 min_prio = 0;
924 990
925 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; ) 991 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
926 if (AvFILLp (coro_ready [prio]) >= 0) 992 if (AvFILLp (coro_ready [prio]) >= 0)
927 {
928 coro_nready--;
929 return av_shift (coro_ready [prio]); 993 return av_shift (coro_ready [prio]);
930 }
931 994
932 return 0; 995 return 0;
933} 996}
934 997
935static int 998static int
… …
943 coro = SvSTATE (coro_sv); 1006 coro = SvSTATE (coro_sv);
944 1007
945 if (coro->flags & CF_READY) 1008 if (coro->flags & CF_READY)
946 return 0; 1009 return 0;
947 1010
948#if 0 /* this is actually harmless */
949 if (coro->flags & CF_RUNNING)
950 croak ("Coro::ready called on currently running coroutine");
951#endif
952
953 coro->flags |= CF_READY; 1011 coro->flags |= CF_READY;
954 1012
955 LOCK; 1013 LOCK;
956 coro_enq (SvREFCNT_inc (coro_sv)); 1014 coro_enq (SvREFCNT_inc (coro_sv));
1015 ++coro_nready;
957 UNLOCK; 1016 UNLOCK;
958 1017
959 return 1; 1018 return 1;
960} 1019}
961 1020
962static int 1021static int
963api_is_ready (SV *coro_sv) 1022api_is_ready (SV *coro_sv)
964{ 1023{
965 return !!SvSTATE (coro_sv)->flags & CF_READY; 1024 return !!(SvSTATE (coro_sv)->flags & CF_READY);
966} 1025}
967 1026
968static void 1027static void
969prepare_schedule (struct transfer_args *ta) 1028prepare_schedule (struct transfer_args *ta)
970{ 1029{
971 SV *prev, *next; 1030 SV *prev_sv, *next_sv;
972 1031
973 for (;;) 1032 for (;;)
974 { 1033 {
975 LOCK; 1034 LOCK;
976 next = coro_deq (PRIO_MIN); 1035 next_sv = coro_deq (PRIO_MIN);
1036
1037 /* nothing to schedule: call the idle handler */
1038 if (!next_sv)
1039 {
1040 dSP;
1041 UNLOCK;
1042
1043 ENTER;
1044 SAVETMPS;
1045
1046 PUSHMARK (SP);
1047 PUTBACK;
1048 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1049
1050 FREETMPS;
1051 LEAVE;
1052 continue;
1053 }
1054
1055 ta->next = SvSTATE (next_sv);
1056
1057 /* cannot transfer to destroyed coros, skip and look for next */
1058 if (ta->next->flags & CF_DESTROYED)
1059 {
1060 UNLOCK;
1061 SvREFCNT_dec (next_sv);
1062 /* coro_nready is already taken care of by destroy */
1063 continue;
1064 }
1065
1066 --coro_nready;
977 UNLOCK; 1067 UNLOCK;
978
979 if (next)
980 break; 1068 break;
981
982 {
983 dSP;
984
985 ENTER;
986 SAVETMPS;
987
988 PUSHMARK (SP);
989 PUTBACK;
990 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
991
992 FREETMPS;
993 LEAVE;
994 } 1069 }
995 }
996
997 prev = SvRV (coro_current);
998 SvRV_set (coro_current, next);
999 1070
1000 /* free this only after the transfer */ 1071 /* free this only after the transfer */
1072 prev_sv = SvRV (coro_current);
1073 SvRV_set (coro_current, next_sv);
1074 ta->prev = SvSTATE (prev_sv);
1075
1076 assert (ta->next->flags & CF_READY);
1077 ta->next->flags &= ~CF_READY;
1078
1001 LOCK; 1079 LOCK;
1002 free_coro_mortal (); 1080 free_coro_mortal ();
1081 coro_mortal = prev_sv;
1003 UNLOCK; 1082 UNLOCK;
1004 coro_mortal = prev;
1005
1006 assert (!SvROK(prev));//D
1007 assert (!SvROK(next));//D
1008
1009 ta->prev = SvSTATE (prev);
1010 ta->next = SvSTATE (next);
1011
1012 assert (ta->next->flags & CF_READY);
1013 ta->next->flags &= ~CF_READY;
1014} 1083}
1015 1084
1016static void 1085static void
1017prepare_cede (struct transfer_args *ta) 1086prepare_cede (struct transfer_args *ta)
1018{ 1087{
1019 api_ready (coro_current); 1088 api_ready (coro_current);
1020
1021 prepare_schedule (ta); 1089 prepare_schedule (ta);
1090}
1091
1092static int
1093prepare_cede_notself (struct transfer_args *ta)
1094{
1095 if (coro_nready)
1096 {
1097 SV *prev = SvRV (coro_current);
1098 prepare_schedule (ta);
1099 api_ready (prev);
1100 return 1;
1101 }
1102 else
1103 return 0;
1022} 1104}
1023 1105
1024static void 1106static void
1025api_schedule (void) 1107api_schedule (void)
1026{ 1108{
… …
1028 1110
1029 prepare_schedule (&ta); 1111 prepare_schedule (&ta);
1030 TRANSFER (ta); 1112 TRANSFER (ta);
1031} 1113}
1032 1114
1033static void 1115static int
1034api_cede (void) 1116api_cede (void)
1035{ 1117{
1036 struct transfer_args ta; 1118 struct transfer_args ta;
1037 1119
1038 prepare_cede (&ta); 1120 prepare_cede (&ta);
1121
1122 if (ta.prev != ta.next)
1123 {
1039 TRANSFER (ta); 1124 TRANSFER (ta);
1125 return 1;
1126 }
1127 else
1128 return 0;
1129}
1130
1131static int
1132api_cede_notself (void)
1133{
1134 struct transfer_args ta;
1135
1136 if (prepare_cede_notself (&ta))
1137 {
1138 TRANSFER (ta);
1139 return 1;
1140 }
1141 else
1142 return 0;
1040} 1143}
1041 1144
1042MODULE = Coro::State PACKAGE = Coro::State 1145MODULE = Coro::State PACKAGE = Coro::State
1043 1146
1044PROTOTYPES: DISABLE 1147PROTOTYPES: DISABLE
… …
1100_set_stacklevel (...) 1203_set_stacklevel (...)
1101 ALIAS: 1204 ALIAS:
1102 Coro::State::transfer = 1 1205 Coro::State::transfer = 1
1103 Coro::schedule = 2 1206 Coro::schedule = 2
1104 Coro::cede = 3 1207 Coro::cede = 3
1208 Coro::cede_notself = 4
1105 CODE: 1209 CODE:
1106{ 1210{
1107 struct transfer_args ta; 1211 struct transfer_args ta;
1108 1212
1109 switch (ix) 1213 switch (ix)
… …
1125 break; 1229 break;
1126 1230
1127 case 3: 1231 case 3:
1128 prepare_cede (&ta); 1232 prepare_cede (&ta);
1129 break; 1233 break;
1234
1235 case 4:
1236 if (!prepare_cede_notself (&ta))
1237 XSRETURN_EMPTY;
1238
1239 break;
1130 } 1240 }
1131 1241
1242 BARRIER;
1132 TRANSFER (ta); 1243 TRANSFER (ta);
1133}
1134 1244
1135void 1245 if (GIMME_V != G_VOID && ta.next != ta.prev)
1136_clone_state_from (SV *dst, SV *src) 1246 XSRETURN_YES;
1247}
1248
1249bool
1250_destroy (SV *coro_sv)
1137 CODE: 1251 CODE:
1138{ 1252 RETVAL = coro_state_destroy (SvSTATE (coro_sv));
1139 struct coro *coro_src = SvSTATE (src); 1253 OUTPUT:
1140 1254 RETVAL
1141 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1142
1143 ++coro_src->refcnt;
1144 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1145}
1146 1255
1147void 1256void
1148_exit (code) 1257_exit (code)
1149 int code 1258 int code
1150 PROTOTYPE: $ 1259 PROTOTYPE: $
… …
1187 coro_ready[i] = newAV (); 1296 coro_ready[i] = newAV ();
1188 1297
1189 { 1298 {
1190 SV *sv = perl_get_sv("Coro::API", 1); 1299 SV *sv = perl_get_sv("Coro::API", 1);
1191 1300
1192 coroapi.schedule = api_schedule; 1301 coroapi.schedule = api_schedule;
1193 coroapi.save = api_save; 1302 coroapi.save = api_save;
1194 coroapi.cede = api_cede; 1303 coroapi.cede = api_cede;
1304 coroapi.cede_notself = api_cede_notself;
1195 coroapi.ready = api_ready; 1305 coroapi.ready = api_ready;
1196 coroapi.is_ready = api_is_ready; 1306 coroapi.is_ready = api_is_ready;
1197 coroapi.nready = &coro_nready; 1307 coroapi.nready = &coro_nready;
1198 coroapi.current = coro_current; 1308 coroapi.current = coro_current;
1199 1309
1200 GCoroAPI = &coroapi; 1310 GCoroAPI = &coroapi;
1201 sv_setiv (sv, (IV)&coroapi); 1311 sv_setiv (sv, (IV)&coroapi);
1202 SvREADONLY_on (sv); 1312 SvREADONLY_on (sv);
1203 } 1313 }
… …
1219 RETVAL = coro->prio; 1329 RETVAL = coro->prio;
1220 1330
1221 if (items > 1) 1331 if (items > 1)
1222 { 1332 {
1223 if (ix) 1333 if (ix)
1224 newprio += coro->prio; 1334 newprio = coro->prio - newprio;
1225 1335
1226 if (newprio < PRIO_MIN) newprio = PRIO_MIN; 1336 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1227 if (newprio > PRIO_MAX) newprio = PRIO_MAX; 1337 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1228 1338
1229 coro->prio = newprio; 1339 coro->prio = newprio;
1230 } 1340 }
1231} 1341}
1342 OUTPUT:
1343 RETVAL
1232 1344
1233SV * 1345SV *
1234ready (SV *self) 1346ready (SV *self)
1235 PROTOTYPE: $ 1347 PROTOTYPE: $
1236 CODE: 1348 CODE:

Diff Legend

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