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.215 by root, Sun Oct 14 19:34:09 2007 UTC vs.
Revision 1.254 by root, Fri Nov 7 20:27:47 2008 UTC

4#define PERL_EXT 4#define PERL_EXT
5 5
6#include "EXTERN.h" 6#include "EXTERN.h"
7#include "perl.h" 7#include "perl.h"
8#include "XSUB.h" 8#include "XSUB.h"
9#include "perliol.h"
9 10
10#include "patchlevel.h" 11#include "patchlevel.h"
11 12
12#include <stdio.h> 13#include <stdio.h>
13#include <errno.h> 14#include <errno.h>
14#include <assert.h> 15#include <assert.h>
16
17#ifdef WIN32
18# undef setjmp
19# undef longjmp
20# undef _exit
21# define setjmp _setjmp // deep magic, don't ask
22#else
15#include <inttypes.h> /* portable stdint.h */ 23# include <inttypes.h> /* most portable stdint.h */
24#endif
16 25
17#ifdef HAVE_MMAP 26#ifdef HAVE_MMAP
18# include <unistd.h> 27# include <unistd.h>
19# include <sys/mman.h> 28# include <sys/mman.h>
20# ifndef MAP_ANONYMOUS 29# ifndef MAP_ANONYMOUS
43#else 52#else
44# define REGISTER_STACK(cctx,start,end) 53# define REGISTER_STACK(cctx,start,end)
45#endif 54#endif
46 55
47/* the maximum number of idle cctx that will be pooled */ 56/* the maximum number of idle cctx that will be pooled */
48#define MAX_IDLE_CCTX 8 57static int cctx_max_idle = 4;
49 58
50#define PERL_VERSION_ATLEAST(a,b,c) \ 59#define PERL_VERSION_ATLEAST(a,b,c) \
51 (PERL_REVISION > (a) \ 60 (PERL_REVISION > (a) \
52 || (PERL_REVISION == (a) \ 61 || (PERL_REVISION == (a) \
53 && (PERL_VERSION > (b) \ 62 && (PERL_VERSION > (b) \
72# ifndef IS_PADCONST 81# ifndef IS_PADCONST
73# define IS_PADCONST(v) 0 82# define IS_PADCONST(v) 0
74# endif 83# endif
75#endif 84#endif
76 85
86/* 5.11 */
87#ifndef CxHASARGS
88# define CxHASARGS(cx) (cx)->blk_sub.hasargs
89#endif
90
91/* 5.10.0 */
92#ifndef SvREFCNT_inc_NN
93# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
94#endif
95
96/* 5.8.8 */
97#ifndef GV_NOTQUAL
98# define GV_NOTQUAL 0
99#endif
100#ifndef newSV
101# define newSV(l) NEWSV(0,l)
102#endif
103
77/* 5.8.7 */ 104/* 5.8.7 */
78#ifndef SvRV_set 105#ifndef SvRV_set
79# define SvRV_set(s,v) SvRV(s) = (v) 106# define SvRV_set(s,v) SvRV(s) = (v)
80#endif
81
82/* 5.8.8 */
83#ifndef GV_NOTQUAL
84# define GV_NOTQUAL 0
85#endif
86#ifndef newSV
87# define newSV(l) NEWSV(0,l)
88#endif 107#endif
89 108
90#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64 109#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
91# undef CORO_STACKGUARD 110# undef CORO_STACKGUARD
92#endif 111#endif
123#define NOINLINE attribute ((noinline)) 142#define NOINLINE attribute ((noinline))
124 143
125#include "CoroAPI.h" 144#include "CoroAPI.h"
126 145
127#ifdef USE_ITHREADS 146#ifdef USE_ITHREADS
128static perl_mutex coro_mutex; 147static perl_mutex coro_lock;
129# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0) 148# define LOCK do { MUTEX_LOCK (&coro_lock); } while (0)
130# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0) 149# define UNLOCK do { MUTEX_UNLOCK (&coro_lock); } while (0)
131#else 150#else
132# define LOCK (void)0 151# define LOCK (void)0
133# define UNLOCK (void)0 152# define UNLOCK (void)0
134#endif 153#endif
135 154
136/* helper storage struct for Coro::AIO */ 155/* helper storage struct for Coro::AIO */
137struct io_state 156struct io_state
138{ 157{
158 AV *res;
139 int errorno; 159 int errorno;
140 I32 laststype; 160 I32 laststype;
141 int laststatval; 161 int laststatval;
142 Stat_t statcache; 162 Stat_t statcache;
143}; 163};
144 164
165static double (*nvtime)(); /* so why doesn't it take void? */
166
167static U32 cctx_gen;
145static size_t coro_stacksize = CORO_STACKSIZE; 168static size_t cctx_stacksize = CORO_STACKSIZE;
146static struct CoroAPI coroapi; 169static struct CoroAPI coroapi;
147static AV *main_mainstack; /* used to differentiate between $main and others */ 170static AV *main_mainstack; /* used to differentiate between $main and others */
148static JMPENV *main_top_env; 171static JMPENV *main_top_env;
149static HV *coro_state_stash, *coro_stash; 172static HV *coro_state_stash, *coro_stash;
150static SV *coro_mortal; /* will be freed after next transfer */ 173static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */
151 174
152static GV *irsgv; /* $/ */ 175static GV *irsgv; /* $/ */
153static GV *stdoutgv; /* *STDOUT */ 176static GV *stdoutgv; /* *STDOUT */
154static SV *rv_diehook; 177static SV *rv_diehook;
155static SV *rv_warnhook; 178static SV *rv_warnhook;
157 180
158/* async_pool helper stuff */ 181/* async_pool helper stuff */
159static SV *sv_pool_rss; 182static SV *sv_pool_rss;
160static SV *sv_pool_size; 183static SV *sv_pool_size;
161static AV *av_async_pool; 184static AV *av_async_pool;
185
186/* Coro::AnyEvent */
187static SV *sv_activity;
162 188
163static struct coro_cctx *cctx_first; 189static struct coro_cctx *cctx_first;
164static int cctx_count, cctx_idle; 190static int cctx_count, cctx_idle;
165 191
166enum { 192enum {
184 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 210 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
185 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */ 211 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
186 JMPENV *top_env; 212 JMPENV *top_env;
187 coro_context cctx; 213 coro_context cctx;
188 214
215 U32 gen;
189#if CORO_USE_VALGRIND 216#if CORO_USE_VALGRIND
190 int valgrind_id; 217 int valgrind_id;
191#endif 218#endif
192 unsigned char flags; 219 unsigned char flags;
193} coro_cctx; 220} coro_cctx;
252#define PRIO_IDLE -3 279#define PRIO_IDLE -3
253#define PRIO_MIN -4 280#define PRIO_MIN -4
254 281
255/* for Coro.pm */ 282/* for Coro.pm */
256static SV *coro_current; 283static SV *coro_current;
284static SV *coro_readyhook;
257static AV *coro_ready [PRIO_MAX-PRIO_MIN+1]; 285static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
258static int coro_nready; 286static int coro_nready;
259static struct coro *coro_first; 287static struct coro *coro_first;
260 288
261/** lowlevel stuff **********************************************************/ 289/** lowlevel stuff **********************************************************/
262 290
263static SV * 291static SV *
264coro_get_sv (pTHX_ const char *name, int create) 292coro_get_sv (pTHX_ const char *name, int create)
265{ 293{
266#if PERL_VERSION_ATLEAST (5,9,0) 294#if PERL_VERSION_ATLEAST (5,10,0)
267 /* silence stupid and wrong 5.10 warning that I am unable to switch off */ 295 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
268 get_sv (name, create); 296 get_sv (name, create);
269#endif 297#endif
270 return get_sv (name, create); 298 return get_sv (name, create);
271} 299}
272 300
273static AV * 301static AV *
274coro_get_av (pTHX_ const char *name, int create) 302coro_get_av (pTHX_ const char *name, int create)
275{ 303{
276#if PERL_VERSION_ATLEAST (5,9,0) 304#if PERL_VERSION_ATLEAST (5,10,0)
277 /* silence stupid and wrong 5.10 warning that I am unable to switch off */ 305 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
278 get_av (name, create); 306 get_av (name, create);
279#endif 307#endif
280 return get_av (name, create); 308 return get_av (name, create);
281} 309}
282 310
283static HV * 311static HV *
284coro_get_hv (pTHX_ const char *name, int create) 312coro_get_hv (pTHX_ const char *name, int create)
285{ 313{
286#if PERL_VERSION_ATLEAST (5,9,0) 314#if PERL_VERSION_ATLEAST (5,10,0)
287 /* silence stupid and wrong 5.10 warning that I am unable to switch off */ 315 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
288 get_hv (name, create); 316 get_hv (name, create);
289#endif 317#endif
290 return get_hv (name, create); 318 return get_hv (name, create);
291} 319}
296 AV *padlist = CvPADLIST (cv); 324 AV *padlist = CvPADLIST (cv);
297 AV *newpadlist, *newpad; 325 AV *newpadlist, *newpad;
298 326
299 newpadlist = newAV (); 327 newpadlist = newAV ();
300 AvREAL_off (newpadlist); 328 AvREAL_off (newpadlist);
301#if PERL_VERSION_ATLEAST (5,9,0) 329#if PERL_VERSION_ATLEAST (5,10,0)
302 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1); 330 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
303#else 331#else
304 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1); 332 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
305#endif 333#endif
306 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)]; 334 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
307 --AvFILLp (padlist); 335 --AvFILLp (padlist);
308 336
309 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE))); 337 av_store (newpadlist, 0, SvREFCNT_inc_NN (*av_fetch (padlist, 0, FALSE)));
310 av_store (newpadlist, 1, (SV *)newpad); 338 av_store (newpadlist, 1, (SV *)newpad);
311 339
312 return newpadlist; 340 return newpadlist;
313} 341}
314 342
344 372
345 /* casting is fun. */ 373 /* casting is fun. */
346 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) 374 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
347 free_padlist (aTHX_ padlist); 375 free_padlist (aTHX_ padlist);
348 376
377 SvREFCNT_dec (av); /* sv_magicext increased the refcount */
378
349 return 0; 379 return 0;
350} 380}
351 381
352#define CORO_MAGIC_type_cv PERL_MAGIC_ext 382#define CORO_MAGIC_type_cv PERL_MAGIC_ext
353#define CORO_MAGIC_type_state PERL_MAGIC_ext 383#define CORO_MAGIC_type_state PERL_MAGIC_ext
355static MGVTBL coro_cv_vtbl = { 385static MGVTBL coro_cv_vtbl = {
356 0, 0, 0, 0, 386 0, 0, 0, 0,
357 coro_cv_free 387 coro_cv_free
358}; 388};
359 389
360#define CORO_MAGIC(sv,type) \ 390#define CORO_MAGIC(sv, type) \
361 SvMAGIC (sv) \ 391 SvMAGIC (sv) \
362 ? SvMAGIC (sv)->mg_type == type \ 392 ? SvMAGIC (sv)->mg_type == type \
363 ? SvMAGIC (sv) \ 393 ? SvMAGIC (sv) \
364 : mg_find (sv, type) \ 394 : mg_find (sv, type) \
365 : 0 395 : 0
366 396
367#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv) 397#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
368#define CORO_MAGIC_state(sv) CORO_MAGIC (((SV *)(sv)), CORO_MAGIC_type_state) 398#define CORO_MAGIC_state(sv) CORO_MAGIC (((SV *)(sv)), CORO_MAGIC_type_state)
369 399
370static struct coro * 400static struct coro *
403 if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)) 433 if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))
404 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--]; 434 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
405 else 435 else
406 { 436 {
407#if CORO_PREFER_PERL_FUNCTIONS 437#if CORO_PREFER_PERL_FUNCTIONS
408 /* this is probably cleaner, but also slower? */ 438 /* this is probably cleaner? but also slower! */
439 /* in practise, it seems to be less stable */
409 CV *cp = Perl_cv_clone (cv); 440 CV *cp = Perl_cv_clone (cv);
410 CvPADLIST (cv) = CvPADLIST (cp); 441 CvPADLIST (cv) = CvPADLIST (cp);
411 CvPADLIST (cp) = 0; 442 CvPADLIST (cp) = 0;
412 SvREFCNT_dec (cp); 443 SvREFCNT_dec (cp);
413#else 444#else
497 528
498 if (expect_true (CvDEPTH (cv))) 529 if (expect_true (CvDEPTH (cv)))
499 { 530 {
500 EXTEND (SP, 3); 531 EXTEND (SP, 3);
501 PUSHs ((SV *)CvPADLIST (cv)); 532 PUSHs ((SV *)CvPADLIST (cv));
502 PUSHs (INT2PTR (SV *, CvDEPTH (cv))); 533 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
503 PUSHs ((SV *)cv); 534 PUSHs ((SV *)cv);
504 535
505 CvDEPTH (cv) = 0; 536 CvDEPTH (cv) = 0;
506 get_padlist (aTHX_ cv); 537 get_padlist (aTHX_ cv);
507 } 538 }
587 618
588 New(54,PL_savestack,24,ANY); 619 New(54,PL_savestack,24,ANY);
589 PL_savestack_ix = 0; 620 PL_savestack_ix = 0;
590 PL_savestack_max = 24; 621 PL_savestack_max = 24;
591 622
592#if !PERL_VERSION_ATLEAST (5,9,0) 623#if !PERL_VERSION_ATLEAST (5,10,0)
593 New(54,PL_retstack,4,OP*); 624 New(54,PL_retstack,4,OP*);
594 PL_retstack_ix = 0; 625 PL_retstack_ix = 0;
595 PL_retstack_max = 4; 626 PL_retstack_max = 4;
596#endif 627#endif
597} 628}
599 630
600/* 631/*
601 * destroy the stacks, the callchain etc... 632 * destroy the stacks, the callchain etc...
602 */ 633 */
603static void 634static void
604coro_destroy_stacks (pTHX) 635coro_destruct_stacks (pTHX)
605{ 636{
606 while (PL_curstackinfo->si_next) 637 while (PL_curstackinfo->si_next)
607 PL_curstackinfo = PL_curstackinfo->si_next; 638 PL_curstackinfo = PL_curstackinfo->si_next;
608 639
609 while (PL_curstackinfo) 640 while (PL_curstackinfo)
620 651
621 Safefree (PL_tmps_stack); 652 Safefree (PL_tmps_stack);
622 Safefree (PL_markstack); 653 Safefree (PL_markstack);
623 Safefree (PL_scopestack); 654 Safefree (PL_scopestack);
624 Safefree (PL_savestack); 655 Safefree (PL_savestack);
625#if !PERL_VERSION_ATLEAST (5,9,0) 656#if !PERL_VERSION_ATLEAST (5,10,0)
626 Safefree (PL_retstack); 657 Safefree (PL_retstack);
627#endif 658#endif
628} 659}
629 660
630static size_t 661static size_t
646 #undef VAR 677 #undef VAR
647 } 678 }
648 else 679 else
649 slot = coro->slot; 680 slot = coro->slot;
650 681
682 if (slot)
683 {
651 rss += sizeof (slot->curstackinfo); 684 rss += sizeof (slot->curstackinfo);
652 rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT); 685 rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
653 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *); 686 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *);
654 rss += slot->tmps_max * sizeof (SV *); 687 rss += slot->tmps_max * sizeof (SV *);
655 rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32); 688 rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32);
656 rss += slot->scopestack_max * sizeof (I32); 689 rss += slot->scopestack_max * sizeof (I32);
657 rss += slot->savestack_max * sizeof (ANY); 690 rss += slot->savestack_max * sizeof (ANY);
658 691
659#if !PERL_VERSION_ATLEAST (5,9,0) 692#if !PERL_VERSION_ATLEAST (5,10,0)
660 rss += slot->retstack_max * sizeof (OP *); 693 rss += slot->retstack_max * sizeof (OP *);
661#endif 694#endif
695 }
662 } 696 }
663 697
664 return rss; 698 return rss;
665} 699}
666 700
667/** coroutine stack handling ************************************************/ 701/** coroutine stack handling ************************************************/
668 702
669#if 0
670static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg); 703static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
704static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
705static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
706
707/* apparently < 5.8.8 */
708#ifndef MgPV_nolen_const
709#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
710 SvPV_nolen((SV*)((mg)->mg_ptr)) : \
711 (const char*)(mg)->mg_ptr)
712#endif
671 713
672/* 714/*
673 * This overrides the default magic get method of %SIG elements. 715 * This overrides the default magic get method of %SIG elements.
674 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook 716 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
675 * and instead of tryign to save and restore the hash elements, we just provide 717 * and instead of tryign to save and restore the hash elements, we just provide
679 * when a schedule happens then, but we ignore this. 721 * when a schedule happens then, but we ignore this.
680 */ 722 */
681static int 723static int
682coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg) 724coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
683{ 725{
684 return orig_sigelem_get (aTHX_ sv, mg);
685 const char *s = MgPV_nolen_const (mg); 726 const char *s = MgPV_nolen_const (mg);
686 727
687 if (*s == '_') 728 if (*s == '_')
688 { 729 {
689 if (strEQ (s, "__DIE__" ) && PL_diehook ) return sv_setsv (sv, PL_diehook ), 0; 730 SV **svp = 0;
690 if (strEQ (s, "__WARN__") && PL_warnhook) return sv_setsv (sv, PL_warnhook), 0; 731
732 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
733 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
734
735 if (svp)
736 {
737 sv_setsv (sv, *svp ? *svp : &PL_sv_undef);
738 return 0;
739 }
740 }
741
742 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
743}
744
745static int
746coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
747{
748 const char *s = MgPV_nolen_const (mg);
749
750 if (*s == '_')
691 } 751 {
752 SV **svp = 0;
692 753
754 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
755 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
756
757 if (svp)
758 {
759 SV *old = *svp;
760 *svp = 0;
761 SvREFCNT_dec (old);
762 return 0;
763 }
764 }
765
766 return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
767}
768
769static int
770coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
771{
772 const char *s = MgPV_nolen_const (mg);
773
774 if (*s == '_')
775 {
776 SV **svp = 0;
777
778 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
779 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
780
781 if (svp)
782 {
783 SV *old = *svp;
784 *svp = newSVsv (sv);
785 SvREFCNT_dec (old);
786 return 0;
787 }
788 }
789
693 return orig_sigelem_get (aTHX_ sv, mg); 790 return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
694} 791}
695#endif
696 792
697static void 793static void
698coro_setup (pTHX_ struct coro *coro) 794coro_setup (pTHX_ struct coro *coro)
699{ 795{
700 /* 796 /*
709 PL_curpm = 0; 805 PL_curpm = 0;
710 PL_curpad = 0; 806 PL_curpad = 0;
711 PL_localizing = 0; 807 PL_localizing = 0;
712 PL_dirty = 0; 808 PL_dirty = 0;
713 PL_restartop = 0; 809 PL_restartop = 0;
810#if PERL_VERSION_ATLEAST (5,10,0)
811 PL_parser = 0;
812#endif
714 813
715 /* recreate the die/warn hooks */ 814 /* recreate the die/warn hooks */
716 PL_diehook = 0; 815 PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
717 hv_store (hv_sig, "__DIE__", sizeof ("__DIE__") - 1, newSV (0), 0); 816 PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
718 PL_diehook = SvREFCNT_inc (rv_diehook);
719
720 PL_warnhook = 0;
721 hv_store (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, newSV (0), 0);
722 PL_warnhook = SvREFCNT_inc (rv_warnhook);
723 817
724 GvSV (PL_defgv) = newSV (0); 818 GvSV (PL_defgv) = newSV (0);
725 GvAV (PL_defgv) = coro->args; coro->args = 0; 819 GvAV (PL_defgv) = coro->args; coro->args = 0;
726 GvSV (PL_errgv) = newSV (0); 820 GvSV (PL_errgv) = newSV (0);
727 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0); 821 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
728 PL_rs = newSVsv (GvSV (irsgv)); 822 PL_rs = newSVsv (GvSV (irsgv));
729 PL_defoutgv = (GV *)SvREFCNT_inc (stdoutgv); 823 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
730 824
731 { 825 {
732 dSP; 826 dSP;
733 LOGOP myop; 827 LOGOP myop;
734 828
751 */ 845 */
752 ENTER; 846 ENTER;
753} 847}
754 848
755static void 849static void
756coro_destroy (pTHX_ struct coro *coro) 850coro_destruct (pTHX_ struct coro *coro)
757{ 851{
758 if (!IN_DESTRUCT) 852 if (!IN_DESTRUCT)
759 { 853 {
760 /* restore all saved variables and stuff */ 854 /* restore all saved variables and stuff */
761 LEAVE_SCOPE (0); 855 LEAVE_SCOPE (0);
783 SvREFCNT_dec (PL_warnhook); 877 SvREFCNT_dec (PL_warnhook);
784 878
785 SvREFCNT_dec (coro->saved_deffh); 879 SvREFCNT_dec (coro->saved_deffh);
786 SvREFCNT_dec (coro->throw); 880 SvREFCNT_dec (coro->throw);
787 881
788 coro_destroy_stacks (aTHX); 882 coro_destruct_stacks (aTHX);
789} 883}
790 884
791static void 885static void
792free_coro_mortal (pTHX) 886free_coro_mortal (pTHX)
793{ 887{
830 : cx->blk_gimme == G_SCALAR ? bot + 1 924 : cx->blk_gimme == G_SCALAR ? bot + 1
831 : bot; 925 : bot;
832 926
833 av_extend (av, top - bot); 927 av_extend (av, top - bot);
834 while (bot < top) 928 while (bot < top)
835 av_push (av, SvREFCNT_inc (*bot++)); 929 av_push (av, SvREFCNT_inc_NN (*bot++));
836 930
837 PL_runops = RUNOPS_DEFAULT; 931 PL_runops = RUNOPS_DEFAULT;
838 ENTER; 932 ENTER;
839 SAVETMPS; 933 SAVETMPS;
840 EXTEND (SP, 3); 934 EXTEND (SP, 3);
878 SAVETMPS; 972 SAVETMPS;
879 EXTEND (SP, 3); 973 EXTEND (SP, 3);
880 PUSHMARK (SP); 974 PUSHMARK (SP);
881 PUSHs (&PL_sv_yes); 975 PUSHs (&PL_sv_yes);
882 PUSHs (fullname); 976 PUSHs (fullname);
883 PUSHs (cx->blk_sub.hasargs ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef); 977 PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
884 PUTBACK; 978 PUTBACK;
885 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0); 979 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
886 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD); 980 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
887 SPAGAIN; 981 SPAGAIN;
888 FREETMPS; 982 FREETMPS;
988 coro_cctx *cctx; 1082 coro_cctx *cctx;
989 void *stack_start; 1083 void *stack_start;
990 size_t stack_size; 1084 size_t stack_size;
991 1085
992 ++cctx_count; 1086 ++cctx_count;
993
994 Newz (0, cctx, 1, coro_cctx); 1087 Newz (0, cctx, 1, coro_cctx);
995 1088
1089 cctx->gen = cctx_gen;
1090
996#if HAVE_MMAP 1091#if HAVE_MMAP
997 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE; 1092 cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
998 /* mmap supposedly does allocate-on-write for us */ 1093 /* mmap supposedly does allocate-on-write for us */
999 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); 1094 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1000 1095
1001 if (cctx->sptr != (void *)-1) 1096 if (cctx->sptr != (void *)-1)
1002 { 1097 {
1008 cctx->flags |= CC_MAPPED; 1103 cctx->flags |= CC_MAPPED;
1009 } 1104 }
1010 else 1105 else
1011#endif 1106#endif
1012 { 1107 {
1013 cctx->ssize = coro_stacksize * (long)sizeof (long); 1108 cctx->ssize = cctx_stacksize * (long)sizeof (long);
1014 New (0, cctx->sptr, coro_stacksize, long); 1109 New (0, cctx->sptr, cctx_stacksize, long);
1015 1110
1016 if (!cctx->sptr) 1111 if (!cctx->sptr)
1017 { 1112 {
1018 perror ("FATAL: unable to allocate stack for coroutine"); 1113 perror ("FATAL: unable to allocate stack for coroutine");
1019 _exit (EXIT_FAILURE); 1114 _exit (EXIT_FAILURE);
1034{ 1129{
1035 if (!cctx) 1130 if (!cctx)
1036 return; 1131 return;
1037 1132
1038 --cctx_count; 1133 --cctx_count;
1134 coro_destroy (&cctx->cctx);
1039 1135
1136 /* coro_transfer creates new, empty cctx's */
1137 if (cctx->sptr)
1138 {
1040#if CORO_USE_VALGRIND 1139#if CORO_USE_VALGRIND
1041 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id); 1140 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1042#endif 1141#endif
1043 1142
1044#if HAVE_MMAP 1143#if HAVE_MMAP
1045 if (cctx->flags & CC_MAPPED) 1144 if (cctx->flags & CC_MAPPED)
1046 munmap (cctx->sptr, cctx->ssize); 1145 munmap (cctx->sptr, cctx->ssize);
1047 else 1146 else
1048#endif 1147#endif
1049 Safefree (cctx->sptr); 1148 Safefree (cctx->sptr);
1149 }
1050 1150
1051 Safefree (cctx); 1151 Safefree (cctx);
1052} 1152}
1053 1153
1054/* wether this cctx should be destructed */ 1154/* wether this cctx should be destructed */
1055#define CCTX_EXPIRED(cctx) ((cctx)->ssize < coro_stacksize || ((cctx)->flags & CC_NOREUSE)) 1155#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1056 1156
1057static coro_cctx * 1157static coro_cctx *
1058cctx_get (pTHX) 1158cctx_get (pTHX)
1059{ 1159{
1060 while (expect_true (cctx_first)) 1160 while (expect_true (cctx_first))
1073} 1173}
1074 1174
1075static void 1175static void
1076cctx_put (coro_cctx *cctx) 1176cctx_put (coro_cctx *cctx)
1077{ 1177{
1178 assert (("cctx_put called on non-initialised cctx", cctx->sptr));
1179
1078 /* free another cctx if overlimit */ 1180 /* free another cctx if overlimit */
1079 if (expect_false (cctx_idle >= MAX_IDLE_CCTX)) 1181 if (expect_false (cctx_idle >= cctx_max_idle))
1080 { 1182 {
1081 coro_cctx *first = cctx_first; 1183 coro_cctx *first = cctx_first;
1082 cctx_first = first->next; 1184 cctx_first = first->next;
1083 --cctx_idle; 1185 --cctx_idle;
1084 1186
1104 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states"); 1206 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
1105 1207
1106 if (expect_false (next->flags & CF_DESTROYED)) 1208 if (expect_false (next->flags & CF_DESTROYED))
1107 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states"); 1209 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
1108 1210
1109 if (
1110#if PERL_VERSION_ATLEAST (5,9,0) 1211#if !PERL_VERSION_ATLEAST (5,10,0)
1111 expect_false (PL_parser)
1112#else
1113 expect_false (PL_lex_state != LEX_NOTPARSING) 1212 if (expect_false (PL_lex_state != LEX_NOTPARSING))
1114#endif
1115 )
1116 croak ("Coro::State::transfer called while parsing, but this is not supported"); 1213 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
1214#endif
1117 } 1215 }
1118} 1216}
1119 1217
1120/* always use the TRANSFER macro */ 1218/* always use the TRANSFER macro */
1121static void NOINLINE 1219static void NOINLINE
1122transfer (pTHX_ struct coro *prev, struct coro *next) 1220transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1123{ 1221{
1124 dSTACKLEVEL; 1222 dSTACKLEVEL;
1125 1223
1126 /* sometimes transfer is only called to set idle_sp */ 1224 /* sometimes transfer is only called to set idle_sp */
1127 if (expect_false (!next)) 1225 if (expect_false (!next))
1129 ((coro_cctx *)prev)->idle_sp = STACKLEVEL; 1227 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
1130 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */ 1228 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1131 } 1229 }
1132 else if (expect_true (prev != next)) 1230 else if (expect_true (prev != next))
1133 { 1231 {
1232 static volatile int has_throw;
1134 coro_cctx *prev__cctx; 1233 coro_cctx *prev__cctx;
1135 1234
1136 if (expect_false (prev->flags & CF_NEW)) 1235 if (expect_false (prev->flags & CF_NEW))
1137 { 1236 {
1138 /* create a new empty context */ 1237 /* create a new empty/source context */
1238 ++cctx_count;
1139 Newz (0, prev->cctx, 1, coro_cctx); 1239 New (0, prev->cctx, 1, coro_cctx);
1240 prev->cctx->sptr = 0;
1241 coro_create (&prev->cctx->cctx, 0, 0, 0, 0);
1242
1140 prev->flags &= ~CF_NEW; 1243 prev->flags &= ~CF_NEW;
1141 prev->flags |= CF_RUNNING; 1244 prev->flags |= CF_RUNNING;
1142 } 1245 }
1143 1246
1144 prev->flags &= ~CF_RUNNING; 1247 prev->flags &= ~CF_RUNNING;
1160 load_perl (aTHX_ next); 1263 load_perl (aTHX_ next);
1161 1264
1162 prev__cctx = prev->cctx; 1265 prev__cctx = prev->cctx;
1163 1266
1164 /* possibly "free" the cctx */ 1267 /* possibly "free" the cctx */
1165 if (expect_true (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE))) 1268 if (expect_true (
1269 prev__cctx->idle_sp == STACKLEVEL
1270 && !(prev__cctx->flags & CC_TRACE)
1271 && !force_cctx
1272 ))
1166 { 1273 {
1167 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */ 1274 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1168 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te)); 1275 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1169 1276
1170 prev->cctx = 0; 1277 prev->cctx = 0;
1180 1287
1181 ++next->usecount; 1288 ++next->usecount;
1182 1289
1183 if (expect_true (!next->cctx)) 1290 if (expect_true (!next->cctx))
1184 next->cctx = cctx_get (aTHX); 1291 next->cctx = cctx_get (aTHX);
1292
1293 has_throw = !!next->throw;
1185 1294
1186 if (expect_false (prev__cctx != next->cctx)) 1295 if (expect_false (prev__cctx != next->cctx))
1187 { 1296 {
1188 prev__cctx->top_env = PL_top_env; 1297 prev__cctx->top_env = PL_top_env;
1189 PL_top_env = next->cctx->top_env; 1298 PL_top_env = next->cctx->top_env;
1191 } 1300 }
1192 1301
1193 free_coro_mortal (aTHX); 1302 free_coro_mortal (aTHX);
1194 UNLOCK; 1303 UNLOCK;
1195 1304
1196 if (expect_false (prev->throw || next->throw)) 1305 if (expect_false (has_throw))
1197 { 1306 {
1198 struct coro *coro = SvSTATE (coro_current); 1307 struct coro *coro = SvSTATE (coro_current);
1199 1308
1200 if (coro->throw) 1309 if (coro->throw)
1201 { 1310 {
1211struct transfer_args 1320struct transfer_args
1212{ 1321{
1213 struct coro *prev, *next; 1322 struct coro *prev, *next;
1214}; 1323};
1215 1324
1216#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next) 1325#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1217#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next) 1326#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1218 1327
1219/** high level stuff ********************************************************/ 1328/** high level stuff ********************************************************/
1220 1329
1221static int 1330static int
1245 croak ("FATAL: tried to destroy currently running coroutine"); 1354 croak ("FATAL: tried to destroy currently running coroutine");
1246 1355
1247 save_perl (aTHX_ &temp); 1356 save_perl (aTHX_ &temp);
1248 load_perl (aTHX_ coro); 1357 load_perl (aTHX_ coro);
1249 1358
1250 coro_destroy (aTHX_ coro); 1359 coro_destruct (aTHX_ coro);
1251 1360
1252 load_perl (aTHX_ &temp); 1361 load_perl (aTHX_ &temp);
1253 1362
1254 coro->slot = 0; 1363 coro->slot = 0;
1255 } 1364 }
1315{ 1424{
1316 dTHX; 1425 dTHX;
1317 struct transfer_args ta; 1426 struct transfer_args ta;
1318 1427
1319 prepare_transfer (aTHX_ &ta, prev_sv, next_sv); 1428 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1320 TRANSFER (ta); 1429 TRANSFER (ta, 1);
1321} 1430}
1322 1431
1323/** Coro ********************************************************************/ 1432/** Coro ********************************************************************/
1324 1433
1325static void 1434static void
1327{ 1436{
1328 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv); 1437 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1329} 1438}
1330 1439
1331static SV * 1440static SV *
1332coro_deq (pTHX_ int min_prio) 1441coro_deq (pTHX)
1333{ 1442{
1334 int prio = PRIO_MAX - PRIO_MIN; 1443 int prio;
1335 1444
1336 min_prio -= PRIO_MIN;
1337 if (min_prio < 0)
1338 min_prio = 0;
1339
1340 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; ) 1445 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
1341 if (AvFILLp (coro_ready [prio]) >= 0) 1446 if (AvFILLp (coro_ready [prio]) >= 0)
1342 return av_shift (coro_ready [prio]); 1447 return av_shift (coro_ready [prio]);
1343 1448
1344 return 0; 1449 return 0;
1345} 1450}
1347static int 1452static int
1348api_ready (SV *coro_sv) 1453api_ready (SV *coro_sv)
1349{ 1454{
1350 dTHX; 1455 dTHX;
1351 struct coro *coro; 1456 struct coro *coro;
1457 SV *sv_hook;
1458 void (*xs_hook)(void);
1352 1459
1353 if (SvROK (coro_sv)) 1460 if (SvROK (coro_sv))
1354 coro_sv = SvRV (coro_sv); 1461 coro_sv = SvRV (coro_sv);
1355 1462
1356 coro = SvSTATE (coro_sv); 1463 coro = SvSTATE (coro_sv);
1359 return 0; 1466 return 0;
1360 1467
1361 coro->flags |= CF_READY; 1468 coro->flags |= CF_READY;
1362 1469
1363 LOCK; 1470 LOCK;
1471
1472 sv_hook = coro_nready ? 0 : coro_readyhook;
1473 xs_hook = coro_nready ? 0 : coroapi.readyhook;
1474
1364 coro_enq (aTHX_ SvREFCNT_inc (coro_sv)); 1475 coro_enq (aTHX_ SvREFCNT_inc_NN (coro_sv));
1365 ++coro_nready; 1476 ++coro_nready;
1477
1366 UNLOCK; 1478 UNLOCK;
1479
1480 if (sv_hook)
1481 {
1482 dSP;
1483
1484 ENTER;
1485 SAVETMPS;
1486
1487 PUSHMARK (SP);
1488 PUTBACK;
1489 call_sv (sv_hook, G_DISCARD);
1490 SPAGAIN;
1491
1492 FREETMPS;
1493 LEAVE;
1494 }
1495
1496 if (xs_hook)
1497 xs_hook ();
1367 1498
1368 return 1; 1499 return 1;
1369} 1500}
1370 1501
1371static int 1502static int
1381 SV *prev_sv, *next_sv; 1512 SV *prev_sv, *next_sv;
1382 1513
1383 for (;;) 1514 for (;;)
1384 { 1515 {
1385 LOCK; 1516 LOCK;
1386 next_sv = coro_deq (aTHX_ PRIO_MIN); 1517 next_sv = coro_deq (aTHX);
1387 1518
1388 /* nothing to schedule: call the idle handler */ 1519 /* nothing to schedule: call the idle handler */
1389 if (expect_false (!next_sv)) 1520 if (expect_false (!next_sv))
1390 { 1521 {
1391 dSP; 1522 dSP;
1395 SAVETMPS; 1526 SAVETMPS;
1396 1527
1397 PUSHMARK (SP); 1528 PUSHMARK (SP);
1398 PUTBACK; 1529 PUTBACK;
1399 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD); 1530 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1531 SPAGAIN;
1400 1532
1401 FREETMPS; 1533 FREETMPS;
1402 LEAVE; 1534 LEAVE;
1403 continue; 1535 continue;
1404 } 1536 }
1459{ 1591{
1460 dTHX; 1592 dTHX;
1461 struct transfer_args ta; 1593 struct transfer_args ta;
1462 1594
1463 prepare_schedule (aTHX_ &ta); 1595 prepare_schedule (aTHX_ &ta);
1464 TRANSFER (ta); 1596 TRANSFER (ta, 1);
1465} 1597}
1466 1598
1467static int 1599static int
1468api_cede (void) 1600api_cede (void)
1469{ 1601{
1472 1604
1473 prepare_cede (aTHX_ &ta); 1605 prepare_cede (aTHX_ &ta);
1474 1606
1475 if (expect_true (ta.prev != ta.next)) 1607 if (expect_true (ta.prev != ta.next))
1476 { 1608 {
1477 TRANSFER (ta); 1609 TRANSFER (ta, 1);
1478 return 1; 1610 return 1;
1479 } 1611 }
1480 else 1612 else
1481 return 0; 1613 return 0;
1482} 1614}
1487 dTHX; 1619 dTHX;
1488 struct transfer_args ta; 1620 struct transfer_args ta;
1489 1621
1490 if (prepare_cede_notself (aTHX_ &ta)) 1622 if (prepare_cede_notself (aTHX_ &ta))
1491 { 1623 {
1492 TRANSFER (ta); 1624 TRANSFER (ta, 1);
1493 return 1; 1625 return 1;
1494 } 1626 }
1495 else 1627 else
1496 return 0; 1628 return 0;
1497} 1629}
1520 else 1652 else
1521 coro->slot->runops = RUNOPS_DEFAULT; 1653 coro->slot->runops = RUNOPS_DEFAULT;
1522 } 1654 }
1523} 1655}
1524 1656
1657static int
1658coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
1659{
1660 AV *padlist;
1661 AV *av = (AV *)mg->mg_obj;
1662
1663 abort ();
1664
1665 return 0;
1666}
1667
1668static MGVTBL coro_gensub_vtbl = {
1669 0, 0, 0, 0,
1670 coro_gensub_free
1671};
1672
1673/*****************************************************************************/
1674/* PerlIO::cede */
1675
1676typedef struct
1677{
1678 PerlIOBuf base;
1679 NV next, every;
1680} PerlIOCede;
1681
1682static IV
1683PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1684{
1685 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1686
1687 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
1688 self->next = nvtime () + self->every;
1689
1690 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
1691}
1692
1693static SV *
1694PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
1695{
1696 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1697
1698 return newSVnv (self->every);
1699}
1700
1701static IV
1702PerlIOCede_flush (pTHX_ PerlIO *f)
1703{
1704 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1705 double now = nvtime ();
1706
1707 if (now >= self->next)
1708 {
1709 api_cede ();
1710 self->next = now + self->every;
1711 }
1712
1713 return PerlIOBuf_flush (aTHX_ f);
1714}
1715
1716static PerlIO_funcs PerlIO_cede =
1717{
1718 sizeof(PerlIO_funcs),
1719 "cede",
1720 sizeof(PerlIOCede),
1721 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
1722 PerlIOCede_pushed,
1723 PerlIOBuf_popped,
1724 PerlIOBuf_open,
1725 PerlIOBase_binmode,
1726 PerlIOCede_getarg,
1727 PerlIOBase_fileno,
1728 PerlIOBuf_dup,
1729 PerlIOBuf_read,
1730 PerlIOBuf_unread,
1731 PerlIOBuf_write,
1732 PerlIOBuf_seek,
1733 PerlIOBuf_tell,
1734 PerlIOBuf_close,
1735 PerlIOCede_flush,
1736 PerlIOBuf_fill,
1737 PerlIOBase_eof,
1738 PerlIOBase_error,
1739 PerlIOBase_clearerr,
1740 PerlIOBase_setlinebuf,
1741 PerlIOBuf_get_base,
1742 PerlIOBuf_bufsiz,
1743 PerlIOBuf_get_ptr,
1744 PerlIOBuf_get_cnt,
1745 PerlIOBuf_set_ptrcnt,
1746};
1747
1748
1525MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_ 1749MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
1526 1750
1527PROTOTYPES: DISABLE 1751PROTOTYPES: DISABLE
1528 1752
1529BOOT: 1753BOOT:
1530{ 1754{
1531#ifdef USE_ITHREADS 1755#ifdef USE_ITHREADS
1532 MUTEX_INIT (&coro_mutex); 1756 MUTEX_INIT (&coro_lock);
1533#endif 1757#endif
1534 BOOT_PAGESIZE; 1758 BOOT_PAGESIZE;
1535 1759
1536 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV); 1760 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
1537 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 1761 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
1538#if 0 1762
1539 orig_sigelem_get = PL_vtbl_sigelem.svt_get; 1763 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
1540 PL_vtbl_sigelem.svt_get = coro_sigelem_get; 1764 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
1541#endif 1765 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
1766
1542 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE); 1767 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
1543 rv_diehook = SvREFCNT_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV)); 1768 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
1544 rv_warnhook = SvREFCNT_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV)); 1769 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
1545 1770
1546 coro_state_stash = gv_stashpv ("Coro::State", TRUE); 1771 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1547 1772
1548 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE)); 1773 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1549 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB)); 1774 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1554 main_top_env = PL_top_env; 1779 main_top_env = PL_top_env;
1555 1780
1556 while (main_top_env->je_prev) 1781 while (main_top_env->je_prev)
1557 main_top_env = main_top_env->je_prev; 1782 main_top_env = main_top_env->je_prev;
1558 1783
1559 coroapi.ver = CORO_API_VERSION; 1784 coroapi.ver = CORO_API_VERSION;
1560 coroapi.rev = CORO_API_REVISION; 1785 coroapi.rev = CORO_API_REVISION;
1561 coroapi.transfer = api_transfer; 1786 coroapi.transfer = api_transfer;
1787
1788 {
1789 SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
1790
1791 if (!svp) croak ("Time::HiRes is required");
1792 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
1793
1794 nvtime = INT2PTR (double (*)(), SvIV (*svp));
1795 }
1562 1796
1563 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL)); 1797 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1564} 1798}
1565 1799
1566SV * 1800SV *
1604 Coro::cede_notself = 4 1838 Coro::cede_notself = 4
1605 CODE: 1839 CODE:
1606{ 1840{
1607 struct transfer_args ta; 1841 struct transfer_args ta;
1608 1842
1843 PUTBACK;
1609 switch (ix) 1844 switch (ix)
1610 { 1845 {
1611 case 0: 1846 case 0:
1612 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0))); 1847 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1613 ta.next = 0; 1848 ta.next = 0;
1614 break; 1849 break;
1615 1850
1616 case 1: 1851 case 1:
1617 if (items != 2) 1852 if (items != 2)
1618 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items); 1853 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d", items);
1619 1854
1620 prepare_transfer (aTHX_ &ta, ST (0), ST (1)); 1855 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
1621 break; 1856 break;
1622 1857
1623 case 2: 1858 case 2:
1632 if (!prepare_cede_notself (aTHX_ &ta)) 1867 if (!prepare_cede_notself (aTHX_ &ta))
1633 XSRETURN_EMPTY; 1868 XSRETURN_EMPTY;
1634 1869
1635 break; 1870 break;
1636 } 1871 }
1872 SPAGAIN;
1637 1873
1638 BARRIER; 1874 BARRIER;
1639 PUTBACK; 1875 PUTBACK;
1640 TRANSFER (ta); 1876 TRANSFER (ta, 0);
1641 SPAGAIN; /* might be the sp of a different coroutine now */ 1877 SPAGAIN; /* might be the sp of a different coroutine now */
1642 /* be extra careful not to ever do anything after TRANSFER */ 1878 /* be extra careful not to ever do anything after TRANSFER */
1643} 1879}
1644 1880
1645bool 1881bool
1648 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv)); 1884 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1649 OUTPUT: 1885 OUTPUT:
1650 RETVAL 1886 RETVAL
1651 1887
1652void 1888void
1653_exit (code) 1889_exit (int code)
1654 int code
1655 PROTOTYPE: $ 1890 PROTOTYPE: $
1656 CODE: 1891 CODE:
1657 _exit (code); 1892 _exit (code);
1658 1893
1659int 1894int
1660cctx_stacksize (int new_stacksize = 0) 1895cctx_stacksize (int new_stacksize = 0)
1661 CODE: 1896 CODE:
1662 RETVAL = coro_stacksize; 1897 RETVAL = cctx_stacksize;
1663 if (new_stacksize) 1898 if (new_stacksize)
1899 {
1664 coro_stacksize = new_stacksize; 1900 cctx_stacksize = new_stacksize;
1901 ++cctx_gen;
1902 }
1903 OUTPUT:
1904 RETVAL
1905
1906int
1907cctx_max_idle (int max_idle = 0)
1908 CODE:
1909 RETVAL = cctx_max_idle;
1910 if (max_idle > 1)
1911 cctx_max_idle = max_idle;
1665 OUTPUT: 1912 OUTPUT:
1666 RETVAL 1913 RETVAL
1667 1914
1668int 1915int
1669cctx_count () 1916cctx_count ()
1693call (Coro::State coro, SV *coderef) 1940call (Coro::State coro, SV *coderef)
1694 ALIAS: 1941 ALIAS:
1695 eval = 1 1942 eval = 1
1696 CODE: 1943 CODE:
1697{ 1944{
1698 if (coro->mainstack) 1945 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
1699 { 1946 {
1700 struct coro temp; 1947 struct coro temp;
1701 1948
1702 if (!(coro->flags & CF_RUNNING)) 1949 if (!(coro->flags & CF_RUNNING))
1703 { 1950 {
1951 PUTBACK;
1704 save_perl (aTHX_ &temp); 1952 save_perl (aTHX_ &temp);
1705 load_perl (aTHX_ coro); 1953 load_perl (aTHX_ coro);
1706 } 1954 }
1707 1955
1708 { 1956 {
1727 1975
1728 if (!(coro->flags & CF_RUNNING)) 1976 if (!(coro->flags & CF_RUNNING))
1729 { 1977 {
1730 save_perl (aTHX_ coro); 1978 save_perl (aTHX_ coro);
1731 load_perl (aTHX_ &temp); 1979 load_perl (aTHX_ &temp);
1980 SPAGAIN;
1732 } 1981 }
1733 } 1982 }
1734} 1983}
1735 1984
1736SV * 1985SV *
1748 1997
1749void 1998void
1750api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB) 1999api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1751 2000
1752SV * 2001SV *
1753has_stack (Coro::State coro) 2002has_cctx (Coro::State coro)
1754 PROTOTYPE: $ 2003 PROTOTYPE: $
1755 CODE: 2004 CODE:
1756 RETVAL = boolSV (!!coro->cctx); 2005 RETVAL = boolSV (!!coro->cctx);
1757 OUTPUT: 2006 OUTPUT:
1758 RETVAL 2007 RETVAL
1777 case 1: RETVAL = coro->usecount; break; 2026 case 1: RETVAL = coro->usecount; break;
1778 } 2027 }
1779 OUTPUT: 2028 OUTPUT:
1780 RETVAL 2029 RETVAL
1781 2030
2031void
2032force_cctx ()
2033 CODE:
2034 struct coro *coro = SvSTATE (coro_current);
2035 coro->cctx->idle_sp = 0;
2036
2037void
2038swap_defsv (Coro::State self)
2039 PROTOTYPE: $
2040 ALIAS:
2041 swap_defav = 1
2042 CODE:
2043 if (!self->slot)
2044 croak ("cannot swap state with coroutine that has no saved state");
2045 else
2046 {
2047 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
2048 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
2049
2050 SV *tmp = *src; *src = *dst; *dst = tmp;
2051 }
1782 2052
1783MODULE = Coro::State PACKAGE = Coro 2053MODULE = Coro::State PACKAGE = Coro
1784 2054
1785BOOT: 2055BOOT:
1786{ 2056{
1787 int i; 2057 int i;
1788 2058
2059 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
1789 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE); 2060 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
1790 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE); 2061 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
1791 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
1792 2062
1793 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE); 2063 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
1794 SvREADONLY_on (coro_current); 2064 SvREADONLY_on (coro_current);
1795 2065
1796 coro_stash = gv_stashpv ("Coro", TRUE); 2066 coro_stash = gv_stashpv ("Coro", TRUE);
1826void 2096void
1827_set_current (SV *current) 2097_set_current (SV *current)
1828 PROTOTYPE: $ 2098 PROTOTYPE: $
1829 CODE: 2099 CODE:
1830 SvREFCNT_dec (SvRV (coro_current)); 2100 SvREFCNT_dec (SvRV (coro_current));
1831 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current))); 2101 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
2102
2103void
2104_set_readyhook (SV *hook)
2105 PROTOTYPE: $
2106 CODE:
2107 LOCK;
2108 SvREFCNT_dec (coro_readyhook);
2109 coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
2110 UNLOCK;
1832 2111
1833int 2112int
1834prio (Coro::State coro, int newprio = 0) 2113prio (Coro::State coro, int newprio = 0)
1835 ALIAS: 2114 ALIAS:
1836 nice = 1 2115 nice = 1
1886 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0); 2165 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1887 AV *invoke_av; 2166 AV *invoke_av;
1888 int i, len; 2167 int i, len;
1889 2168
1890 if (!invoke) 2169 if (!invoke)
2170 {
2171 SV *old = PL_diehook;
2172 PL_diehook = 0;
2173 SvREFCNT_dec (old);
1891 croak ("\3async_pool terminate\2\n"); 2174 croak ("\3async_pool terminate\2\n");
2175 }
1892 2176
1893 SvREFCNT_dec (coro->saved_deffh); 2177 SvREFCNT_dec (coro->saved_deffh);
1894 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv); 2178 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
1895 2179
1896 hv_store (hv, "desc", sizeof ("desc") - 1, 2180 hv_store (hv, "desc", sizeof ("desc") - 1,
1897 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0); 2181 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
1898 2182
1899 invoke_av = (AV *)SvRV (invoke); 2183 invoke_av = (AV *)SvRV (invoke);
1903 2187
1904 if (len > 0) 2188 if (len > 0)
1905 { 2189 {
1906 av_fill (defav, len - 1); 2190 av_fill (defav, len - 1);
1907 for (i = 0; i < len; ++i) 2191 for (i = 0; i < len; ++i)
1908 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1])); 2192 av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
1909 } 2193 }
1910 2194
1911 SvREFCNT_dec (invoke); 2195 SvREFCNT_dec (invoke);
1912} 2196}
1913 2197
1922 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh; 2206 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1923 coro->saved_deffh = 0; 2207 coro->saved_deffh = 0;
1924 2208
1925 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss) 2209 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1926 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size)) 2210 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2211 {
2212 SV *old = PL_diehook;
2213 PL_diehook = 0;
2214 SvREFCNT_dec (old);
1927 croak ("\3async_pool terminate\2\n"); 2215 croak ("\3async_pool terminate\2\n");
2216 }
1928 2217
1929 av_clear (GvAV (PL_defgv)); 2218 av_clear (GvAV (PL_defgv));
1930 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1, 2219 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1931 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0); 2220 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1932 2221
1936 api_trace (coro_current, 0); 2225 api_trace (coro_current, 0);
1937 2226
1938 av_push (av_async_pool, newSVsv (coro_current)); 2227 av_push (av_async_pool, newSVsv (coro_current));
1939} 2228}
1940 2229
2230#if 0
2231
2232void
2233_generator_call (...)
2234 PROTOTYPE: @
2235 PPCODE:
2236 fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
2237 xxxx
2238 abort ();
2239
2240SV *
2241gensub (SV *sub, ...)
2242 PROTOTYPE: &;@
2243 CODE:
2244{
2245 struct coro *coro;
2246 MAGIC *mg;
2247 CV *xcv;
2248 CV *ncv = (CV *)newSV_type (SVt_PVCV);
2249 int i;
2250
2251 CvGV (ncv) = CvGV (cv);
2252 CvFILE (ncv) = CvFILE (cv);
2253
2254 Newz (0, coro, 1, struct coro);
2255 coro->args = newAV ();
2256 coro->flags = CF_NEW;
2257
2258 av_extend (coro->args, items - 1);
2259 for (i = 1; i < items; i++)
2260 av_push (coro->args, newSVsv (ST (i)));
2261
2262 CvISXSUB_on (ncv);
2263 CvXSUBANY (ncv).any_ptr = (void *)coro;
2264
2265 xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
2266
2267 CvXSUB (ncv) = CvXSUB (xcv);
2268 CvANON_on (ncv);
2269
2270 mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
2271 RETVAL = newRV_noinc ((SV *)ncv);
2272}
2273 OUTPUT:
2274 RETVAL
2275
2276#endif
2277
1941 2278
1942MODULE = Coro::State PACKAGE = Coro::AIO 2279MODULE = Coro::State PACKAGE = Coro::AIO
1943 2280
1944SV * 2281void
1945_get_state () 2282_get_state (SV *self)
1946 CODE: 2283 PPCODE:
1947{ 2284{
1948 struct io_state *data; 2285 AV *defav = GvAV (PL_defgv);
1949 2286 AV *av = newAV ();
2287 int i;
1950 RETVAL = newSV (sizeof (struct io_state)); 2288 SV *data_sv = newSV (sizeof (struct io_state));
1951 data = (struct io_state *)SvPVX (RETVAL); 2289 struct io_state *data = (struct io_state *)SvPVX (data_sv);
1952 SvCUR_set (RETVAL, sizeof (struct io_state)); 2290 SvCUR_set (data_sv, sizeof (struct io_state));
1953 SvPOK_only (RETVAL); 2291 SvPOK_only (data_sv);
1954 2292
1955 data->errorno = errno; 2293 data->errorno = errno;
1956 data->laststype = PL_laststype; 2294 data->laststype = PL_laststype;
1957 data->laststatval = PL_laststatval; 2295 data->laststatval = PL_laststatval;
1958 data->statcache = PL_statcache; 2296 data->statcache = PL_statcache;
2297
2298 av_extend (av, AvFILLp (defav) + 1 + 1);
2299
2300 for (i = 0; i <= AvFILLp (defav); ++i)
2301 av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
2302
2303 av_push (av, data_sv);
2304
2305 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
2306
2307 api_ready (self);
1959} 2308}
1960 OUTPUT:
1961 RETVAL
1962 2309
1963void 2310void
1964_set_state (char *data_) 2311_set_state (SV *state)
1965 PROTOTYPE: $ 2312 PROTOTYPE: $
1966 CODE: 2313 PPCODE:
1967{ 2314{
1968 struct io_state *data = (void *)data_; 2315 AV *av = (AV *)SvRV (state);
2316 struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
2317 int i;
1969 2318
1970 errno = data->errorno; 2319 errno = data->errorno;
1971 PL_laststype = data->laststype; 2320 PL_laststype = data->laststype;
1972 PL_laststatval = data->laststatval; 2321 PL_laststatval = data->laststatval;
1973 PL_statcache = data->statcache; 2322 PL_statcache = data->statcache;
1974}
1975 2323
2324 EXTEND (SP, AvFILLp (av));
2325 for (i = 0; i < AvFILLp (av); ++i)
2326 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
2327}
2328
2329
2330MODULE = Coro::State PACKAGE = Coro::AnyEvent
2331
2332BOOT:
2333 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
2334
2335SV *
2336_schedule (...)
2337 PROTOTYPE: @
2338 CODE:
2339{
2340 static int incede;
2341
2342 api_cede_notself ();
2343
2344 ++incede;
2345 while (coro_nready >= incede && api_cede ())
2346 ;
2347
2348 sv_setsv (sv_activity, &PL_sv_undef);
2349 if (coro_nready >= incede)
2350 {
2351 PUSHMARK (SP);
2352 PUTBACK;
2353 call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
2354 SPAGAIN;
2355 }
2356
2357 --incede;
2358}
2359
2360
2361MODULE = Coro::State PACKAGE = PerlIO::cede
2362
2363BOOT:
2364 PerlIO_define_layer (aTHX_ &PerlIO_cede);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines