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.410 by root, Sun Jun 12 08:14:12 2011 UTC vs.
Revision 1.462 by root, Wed Jun 22 20:24:38 2016 UTC

1/* this works around a bug in mingw32 providing a non-working setjmp */ 1/* this works around a bug in mingw32 providing a non-working setjmp */
2#define USE_NO_MINGW_SETJMP_TWO_ARGS 2#define USE_NO_MINGW_SETJMP_TWO_ARGS
3 3
4#define NDEBUG 1 4#define NDEBUG 1 /* perl usually disables NDEBUG later */
5 5
6#include "libcoro/coro.c" 6#include "libcoro/coro.c"
7 7
8#define PERL_NO_GET_CONTEXT 8#define PERL_NO_GET_CONTEXT
9#define PERL_EXT 9#define PERL_EXT
12#include "perl.h" 12#include "perl.h"
13#include "XSUB.h" 13#include "XSUB.h"
14#include "perliol.h" 14#include "perliol.h"
15 15
16#include "schmorp.h" 16#include "schmorp.h"
17
18#define ECB_NO_THREADS 1
19#define ECB_NO_LIBM 1
17#include "ecb.h" 20#include "ecb.h"
18 21
19#include <stddef.h> 22#include <stddef.h>
20#include <stdio.h> 23#include <stdio.h>
21#include <errno.h> 24#include <errno.h>
22#include <assert.h> 25#include <assert.h>
23 26
27#ifndef SvREFCNT_dec_NN
28 #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv)
29#endif
30
31#ifndef SvREFCNT_inc_NN
32 #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
33#endif
34
24#ifndef SVs_PADSTALE 35#ifndef SVs_PADSTALE
25# define SVs_PADSTALE 0 36# define SVs_PADSTALE 0
37#endif
38
39#ifdef PadARRAY
40# define NEWPADAPI 1
41# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *))
42#else
43typedef AV PADNAMELIST;
44# if !PERL_VERSION_ATLEAST(5,8,0)
45typedef AV PADLIST;
46typedef AV PAD;
47# endif
48# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
49# define PadlistMAX(pl) AvFILLp (pl)
50# define PadlistNAMES(pl) (*PadlistARRAY (pl))
51# define PadARRAY AvARRAY
52# define PadMAX AvFILLp
53# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1))
54#endif
55#ifndef PadnamelistREFCNT
56# define PadnamelistREFCNT(pnl) SvREFCNT (pnl)
57#endif
58#ifndef PadnamelistREFCNT_dec
59# define PadnamelistREFCNT_dec(pnl) SvREFCNT_dec (pnl)
60#endif
61
62/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
63/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
64#if PERL_VERSION_ATLEAST(5,19,0)
65# define SVt_BIND SVt_IV
26#endif 66#endif
27 67
28#if defined(_WIN32) 68#if defined(_WIN32)
29# undef HAS_GETTIMEOFDAY 69# undef HAS_GETTIMEOFDAY
30# undef setjmp 70# undef setjmp
33# define setjmp _setjmp /* deep magic */ 73# define setjmp _setjmp /* deep magic */
34#else 74#else
35# include <inttypes.h> /* most portable stdint.h */ 75# include <inttypes.h> /* most portable stdint.h */
36#endif 76#endif
37 77
38#if HAVE_MMAP
39# include <unistd.h>
40# include <sys/mman.h>
41# ifndef MAP_ANONYMOUS
42# ifdef MAP_ANON
43# define MAP_ANONYMOUS MAP_ANON
44# else
45# undef HAVE_MMAP
46# endif
47# endif
48# include <limits.h>
49# ifndef PAGESIZE
50# define PAGESIZE pagesize
51# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
52static long pagesize;
53# else
54# define BOOT_PAGESIZE (void)0
55# endif
56#else
57# define PAGESIZE 0
58# define BOOT_PAGESIZE (void)0
59#endif
60
61#if CORO_USE_VALGRIND
62# include <valgrind/valgrind.h>
63#endif
64
65/* the maximum number of idle cctx that will be pooled */ 78/* the maximum number of idle cctx that will be pooled */
66static int cctx_max_idle = 4; 79static int cctx_max_idle = 4;
67 80
68#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64 81#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
69# undef CORO_STACKGUARD 82# define HAS_SCOPESTACK_NAME 1
70#endif
71
72#ifndef CORO_STACKGUARD
73# define CORO_STACKGUARD 0
74#endif 83#endif
75 84
76/* prefer perl internal functions over our own? */ 85/* prefer perl internal functions over our own? */
77#ifndef CORO_PREFER_PERL_FUNCTIONS 86#ifndef CORO_PREFER_PERL_FUNCTIONS
78# define CORO_PREFER_PERL_FUNCTIONS 0 87# define CORO_PREFER_PERL_FUNCTIONS 0
97# if CORO_PTHREAD 106# if CORO_PTHREAD
98static void *coro_thx; 107static void *coro_thx;
99# endif 108# endif
100#endif 109#endif
101 110
102/* used in state.h */
103#define VAR(name,type) VARx(name, PL_ ## name, type)
104
105#ifdef __linux 111#ifdef __linux
106# include <time.h> /* for timespec */ 112# include <time.h> /* for timespec */
107# include <syscall.h> /* for SYS_* */ 113# include <syscall.h> /* for SYS_* */
108# ifdef SYS_clock_gettime 114# ifdef SYS_clock_gettime
109# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts)) 115# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
134 140
135static GV *irsgv; /* $/ */ 141static GV *irsgv; /* $/ */
136static GV *stdoutgv; /* *STDOUT */ 142static GV *stdoutgv; /* *STDOUT */
137static SV *rv_diehook; 143static SV *rv_diehook;
138static SV *rv_warnhook; 144static SV *rv_warnhook;
139static HV *hv_sig; /* %SIG */
140 145
141/* async_pool helper stuff */ 146/* async_pool helper stuff */
142static SV *sv_pool_rss; 147static SV *sv_pool_rss;
143static SV *sv_pool_size; 148static SV *sv_pool_size;
144static SV *sv_async_pool_idle; /* description string */ 149static SV *sv_async_pool_idle; /* description string */
172typedef struct coro_cctx 177typedef struct coro_cctx
173{ 178{
174 struct coro_cctx *next; 179 struct coro_cctx *next;
175 180
176 /* the stack */ 181 /* the stack */
177 void *sptr; 182 struct coro_stack stack;
178 size_t ssize;
179 183
180 /* cpu state */ 184 /* cpu state */
181 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 185 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
186#ifndef NDEBUG
182 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */ 187 JMPENV *idle_te; /* same as idle_sp, but for top_env */
188#endif
183 JMPENV *top_env; 189 JMPENV *top_env;
184 coro_context cctx; 190 coro_context cctx;
185 191
186 U32 gen; 192 U32 gen;
187#if CORO_USE_VALGRIND 193#if CORO_USE_VALGRIND
207}; 213};
208 214
209/* the structure where most of the perl state is stored, overlaid on the cxstack */ 215/* the structure where most of the perl state is stored, overlaid on the cxstack */
210typedef struct 216typedef struct
211{ 217{
212#define VARx(name,expr,type) type name; 218 #define VARx(name,expr,type) type name;
213# include "state.h" 219 #include "state.h"
214#undef VARx
215} perl_slots; 220} perl_slots;
216 221
217/* how many context stack entries do we need for perl_slots */ 222/* how many context stack entries do we need for perl_slots */
218#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT)) 223#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
219 224
250 SV *saved_deffh; 255 SV *saved_deffh;
251 SV *invoke_cb; 256 SV *invoke_cb;
252 AV *invoke_av; 257 AV *invoke_av;
253 258
254 /* on_enter/on_leave */ 259 /* on_enter/on_leave */
255 AV *on_enter; 260 AV *on_enter; AV *on_enter_xs;
256 AV *on_leave; 261 AV *on_leave; AV *on_leave_xs;
257 262
258 /* swap_sv */ 263 /* swap_sv */
259 AV *swap_sv; 264 AV *swap_sv;
260 265
261 /* times */ 266 /* times */
291#define coro_nready coroapi.nready 296#define coro_nready coroapi.nready
292 297
293/** JIT *********************************************************************/ 298/** JIT *********************************************************************/
294 299
295#if CORO_JIT 300#if CORO_JIT
296 /* APPLE doesn't have HAVE_MMAP though */ 301 /* APPLE doesn't have mmap though */
297 #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__) 302 #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)
298 #ifndef CORO_JIT_TYPE 303 #ifndef CORO_JIT_TYPE
299 #if __x86_64 && CORO_JIT_UNIXY 304 #if ECB_AMD64 && CORO_JIT_UNIXY
300 #define CORO_JIT_TYPE "amd64-unix" 305 #define CORO_JIT_TYPE "amd64-unix"
301 #elif __i386 && CORO_JIT_UNIXY 306 #elif __i386 && CORO_JIT_UNIXY
302 #define CORO_JIT_TYPE "x86-unix" 307 #define CORO_JIT_TYPE "x86-unix"
303 #endif 308 #endif
304 #endif 309 #endif
305#endif 310#endif
306 311
307#if !defined(CORO_JIT_TYPE) || !HAVE_MMAP 312#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0
308 #undef CORO_JIT 313 #undef CORO_JIT
309#endif 314#endif
310 315
311#if CORO_JIT 316#if CORO_JIT
312 typedef void (*load_save_perl_slots_type)(perl_slots *); 317 typedef void (*load_save_perl_slots_type)(perl_slots *);
335 340
336/** time stuff **************************************************************/ 341/** time stuff **************************************************************/
337 342
338#ifdef HAS_GETTIMEOFDAY 343#ifdef HAS_GETTIMEOFDAY
339 344
340ECB_INLINE void 345ecb_inline void
341coro_u2time (pTHX_ UV ret[2]) 346coro_u2time (pTHX_ UV ret[2])
342{ 347{
343 struct timeval tv; 348 struct timeval tv;
344 gettimeofday (&tv, 0); 349 gettimeofday (&tv, 0);
345 350
346 ret [0] = tv.tv_sec; 351 ret [0] = tv.tv_sec;
347 ret [1] = tv.tv_usec; 352 ret [1] = tv.tv_usec;
348} 353}
349 354
350ECB_INLINE double 355ecb_inline double
351coro_nvtime (void) 356coro_nvtime (void)
352{ 357{
353 struct timeval tv; 358 struct timeval tv;
354 gettimeofday (&tv, 0); 359 gettimeofday (&tv, 0);
355 360
356 return tv.tv_sec + tv.tv_usec * 1e-6; 361 return tv.tv_sec + tv.tv_usec * 1e-6;
357} 362}
358 363
359ECB_INLINE void 364ecb_inline void
360time_init (pTHX) 365time_init (pTHX)
361{ 366{
362 nvtime = coro_nvtime; 367 nvtime = coro_nvtime;
363 u2time = coro_u2time; 368 u2time = coro_u2time;
364} 369}
365 370
366#else 371#else
367 372
368ECB_INLINE void 373ecb_inline void
369time_init (pTHX) 374time_init (pTHX)
370{ 375{
371 SV **svp; 376 SV **svp;
372 377
373 require_pv ("Time/HiRes.pm"); 378 require_pv ("Time/HiRes.pm");
374 379
375 svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0); 380 svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
376 381
377 if (!svp) croak ("Time::HiRes is required, but missing. Caught"); 382 if (!svp) croak ("Time::HiRes is required, but missing. Caught");
378 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught"); 383 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
379 384
415 get_hv (name, create); 420 get_hv (name, create);
416#endif 421#endif
417 return get_hv (name, create); 422 return get_hv (name, create);
418} 423}
419 424
420ECB_INLINE void 425ecb_inline void
421coro_times_update (void) 426coro_times_update (void)
422{ 427{
423#ifdef coro_clock_gettime 428#ifdef coro_clock_gettime
424 struct timespec ts; 429 struct timespec ts;
425 430
438 time_real [0] = tv [0]; 443 time_real [0] = tv [0];
439 time_real [1] = tv [1] * 1000; 444 time_real [1] = tv [1] * 1000;
440#endif 445#endif
441} 446}
442 447
443ECB_INLINE void 448ecb_inline void
444coro_times_add (struct coro *c) 449coro_times_add (struct coro *c)
445{ 450{
446 c->t_real [1] += time_real [1]; 451 c->t_real [1] += time_real [1];
447 if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; } 452 if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
448 c->t_real [0] += time_real [0]; 453 c->t_real [0] += time_real [0];
450 c->t_cpu [1] += time_cpu [1]; 455 c->t_cpu [1] += time_cpu [1];
451 if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; } 456 if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }
452 c->t_cpu [0] += time_cpu [0]; 457 c->t_cpu [0] += time_cpu [0];
453} 458}
454 459
455ECB_INLINE void 460ecb_inline void
456coro_times_sub (struct coro *c) 461coro_times_sub (struct coro *c)
457{ 462{
458 if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; } 463 if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }
459 c->t_real [1] -= time_real [1]; 464 c->t_real [1] -= time_real [1];
460 c->t_real [0] -= time_real [0]; 465 c->t_real [0] -= time_real [0];
481 : 0) 486 : 0)
482 487
483#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv) 488#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
484#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state) 489#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)
485 490
486ECB_INLINE MAGIC * 491ecb_inline MAGIC *
487SvSTATEhv_p (pTHX_ SV *coro) 492SvSTATEhv_p (pTHX_ SV *coro)
488{ 493{
489 MAGIC *mg; 494 MAGIC *mg;
490 495
491 if (ecb_expect_true ( 496 if (ecb_expect_true (
496 return mg; 501 return mg;
497 502
498 return 0; 503 return 0;
499} 504}
500 505
501ECB_INLINE struct coro * 506ecb_inline struct coro *
502SvSTATE_ (pTHX_ SV *coro) 507SvSTATE_ (pTHX_ SV *coro_sv)
503{ 508{
504 MAGIC *mg; 509 MAGIC *mg;
505 510
506 if (SvROK (coro)) 511 if (SvROK (coro_sv))
507 coro = SvRV (coro); 512 coro_sv = SvRV (coro_sv);
508 513
509 mg = SvSTATEhv_p (aTHX_ coro); 514 mg = SvSTATEhv_p (aTHX_ coro_sv);
510 if (!mg) 515 if (!mg)
511 croak ("Coro::State object required"); 516 croak ("Coro::State object required");
512 517
513 return (struct coro *)mg->mg_ptr; 518 return (struct coro *)mg->mg_ptr;
514} 519}
520#define SvSTATE_current SvSTATE_hv (SvRV (coro_current)) 525#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
521 526
522/*****************************************************************************/ 527/*****************************************************************************/
523/* padlist management and caching */ 528/* padlist management and caching */
524 529
525ECB_INLINE AV * 530ecb_inline PADLIST *
526coro_derive_padlist (pTHX_ CV *cv) 531coro_derive_padlist (pTHX_ CV *cv)
527{ 532{
528 AV *padlist = CvPADLIST (cv); 533 PADLIST *padlist = CvPADLIST (cv);
529 AV *newpadlist, *newpad; 534 PADLIST *newpadlist;
535 PADNAMELIST *padnames;
536 PAD *newpad;
537 PADOFFSET off = PadlistMAX (padlist) + 1;
530 538
531 newpadlist = newAV (); 539#if NEWPADAPI
540
541 /* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
542 /* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
543 while (!PadlistARRAY (padlist)[off - 1])
544 --off;
545
546 Perl_pad_push (aTHX_ padlist, off);
547
548 newpad = PadlistARRAY (padlist)[off];
549 PadlistARRAY (padlist)[off] = 0;
550
551#else
552
553#if PERL_VERSION_ATLEAST (5,10,0)
554 Perl_pad_push (aTHX_ padlist, off);
555#else
556 Perl_pad_push (aTHX_ padlist, off, 1);
557#endif
558
559 newpad = PadlistARRAY (padlist)[off];
560 PadlistMAX (padlist) = off - 1;
561
562#endif
563
564 newPADLIST (newpadlist);
565#if !PERL_VERSION_ATLEAST(5,15,3)
566 /* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */
532 AvREAL_off (newpadlist); 567 AvREAL_off (newpadlist);
533#if PERL_VERSION_ATLEAST (5,10,0)
534 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
535#else
536 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
537#endif 568#endif
538 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
539 --AvFILLp (padlist);
540 569
541 av_store (newpadlist, 0, SvREFCNT_inc_NN (AvARRAY (padlist)[0])); 570 /* Already extended to 2 elements by newPADLIST. */
542 av_store (newpadlist, 1, (SV *)newpad); 571 PadlistMAX (newpadlist) = 1;
572
573 padnames = PadlistNAMES (padlist);
574 ++PadnamelistREFCNT (padnames);
575 PadlistNAMES (newpadlist) = padnames;
576
577 PadlistARRAY (newpadlist)[1] = newpad;
543 578
544 return newpadlist; 579 return newpadlist;
545} 580}
546 581
547ECB_INLINE void 582ecb_inline void
548free_padlist (pTHX_ AV *padlist) 583free_padlist (pTHX_ PADLIST *padlist)
549{ 584{
550 /* may be during global destruction */ 585 /* may be during global destruction */
551 if (!IN_DESTRUCT) 586 if (!IN_DESTRUCT)
552 { 587 {
553 I32 i = AvFILLp (padlist); 588 I32 i = PadlistMAX (padlist);
554 589
555 while (i > 0) /* special-case index 0 */ 590 while (i > 0) /* special-case index 0 */
556 { 591 {
557 /* we try to be extra-careful here */ 592 /* we try to be extra-careful here */
558 AV *av = (AV *)AvARRAY (padlist)[i--]; 593 PAD *pad = PadlistARRAY (padlist)[i--];
559 I32 j = AvFILLp (av);
560 594
595 if (pad)
596 {
597 I32 j = PadMAX (pad);
598
561 while (j >= 0) 599 while (j >= 0)
562 SvREFCNT_dec (AvARRAY (av)[j--]); 600 SvREFCNT_dec (PadARRAY (pad)[j--]);
563 601
564 AvFILLp (av) = -1; 602 PadMAX (pad) = -1;
565 SvREFCNT_dec (av); 603 SvREFCNT_dec (pad);
604 }
566 } 605 }
567 606
568 SvREFCNT_dec (AvARRAY (padlist)[0]); 607 PadnamelistREFCNT_dec (PadlistNAMES (padlist));
569 608
609#if NEWPADAPI
610 Safefree (PadlistARRAY (padlist));
611 Safefree (padlist);
612#else
570 AvFILLp (padlist) = -1; 613 AvFILLp (padlist) = -1;
614 AvREAL_off (padlist);
571 SvREFCNT_dec ((SV*)padlist); 615 SvREFCNT_dec ((SV*)padlist);
616#endif
572 } 617 }
573} 618}
574 619
575static int 620static int
576coro_cv_free (pTHX_ SV *sv, MAGIC *mg) 621coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
577{ 622{
578 AV *padlist; 623 PADLIST *padlist;
579 AV *av = (AV *)mg->mg_obj; 624 PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t));
625 size_t len = *(size_t *)mg->mg_ptr;
580 626
581 /* perl manages to free our internal AV and _then_ call us */ 627 /* perl manages to free our internal AV and _then_ call us */
582 if (IN_DESTRUCT) 628 if (IN_DESTRUCT)
583 return 0; 629 return 0;
584 630
585 /* casting is fun. */ 631 while (len--)
586 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
587 free_padlist (aTHX_ padlist); 632 free_padlist (aTHX_ padlists[len]);
588
589 SvREFCNT_dec (av); /* sv_magicext increased the refcount */
590 633
591 return 0; 634 return 0;
592} 635}
593 636
594static MGVTBL coro_cv_vtbl = { 637static MGVTBL coro_cv_vtbl = {
595 0, 0, 0, 0, 638 0, 0, 0, 0,
596 coro_cv_free 639 coro_cv_free
597}; 640};
598 641
599/* the next two functions merely cache the padlists */ 642/* the next two functions merely cache the padlists */
600ECB_INLINE void 643ecb_inline void
601get_padlist (pTHX_ CV *cv) 644get_padlist (pTHX_ CV *cv)
602{ 645{
603 MAGIC *mg = CORO_MAGIC_cv (cv); 646 MAGIC *mg = CORO_MAGIC_cv (cv);
604 AV *av; 647 size_t *lenp;
605 648
606 if (ecb_expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)) 649 if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
607 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--]; 650 CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
608 else 651 else
609 { 652 {
610#if CORO_PREFER_PERL_FUNCTIONS 653#if CORO_PREFER_PERL_FUNCTIONS
611 /* this is probably cleaner? but also slower! */ 654 /* this is probably cleaner? but also slower! */
612 /* in practise, it seems to be less stable */ 655 /* in practise, it seems to be less stable */
618 CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv); 661 CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
619#endif 662#endif
620 } 663 }
621} 664}
622 665
623ECB_INLINE void 666ecb_inline void
624put_padlist (pTHX_ CV *cv) 667put_padlist (pTHX_ CV *cv)
625{ 668{
626 MAGIC *mg = CORO_MAGIC_cv (cv); 669 MAGIC *mg = CORO_MAGIC_cv (cv);
627 AV *av;
628 670
629 if (ecb_expect_false (!mg)) 671 if (ecb_expect_false (!mg))
672 {
630 mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0); 673 mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
674 Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char);
675 mg->mg_len = 1; /* so mg_free frees mg_ptr */
676 }
677 else
678 Renew (mg->mg_ptr,
679 sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *),
680 char);
631 681
632 av = (AV *)mg->mg_obj; 682 ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
633
634 if (ecb_expect_false (AvFILLp (av) >= AvMAX (av)))
635 av_extend (av, AvFILLp (av) + 1);
636
637 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
638} 683}
639 684
640/** load & save, init *******************************************************/ 685/** load & save, init *******************************************************/
641 686
687ecb_inline void
688swap_sv (SV *a, SV *b)
689{
690 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
691 SV tmp;
692
693 /* swap sv_any */
694 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
695
696 /* swap sv_flags */
697 SvFLAGS (&tmp) = SvFLAGS (a);
698 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
699 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
700
701#if PERL_VERSION_ATLEAST (5,10,0)
702 /* perl 5.10 and later complicates this _quite_ a bit, but it also
703 * is much faster, so no quarrels here. alternatively, we could
704 * sv_upgrade to avoid this.
705 */
706 {
707 /* swap sv_u */
708 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
709
710 /* if SvANY points to the head, we need to adjust the pointers,
711 * as the pointer for a still points to b, and maybe vice versa.
712 */
713 U32 svany_in_head_set = (1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV);
714 #if NVSIZE <= IVSIZE && PERL_VERSION_ATLEAST(5,22,0)
715 svany_in_head_set |= 1 << SVt_NV;
716 #endif
717
718 #define svany_in_head(type) (svany_in_head_set & (1 << (type)))
719
720 if (svany_in_head (SvTYPE (a)))
721 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
722
723 if (svany_in_head (SvTYPE (b)))
724 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
725 }
726#endif
727}
728
642/* swap sv heads, at least logically */ 729/* swap sv heads, at least logically */
643static void 730static void
644swap_svs (pTHX_ Coro__State c) 731swap_svs_enter (pTHX_ Coro__State c)
645{ 732{
646 int i; 733 int i;
647 734
648 for (i = 0; i <= AvFILLp (c->swap_sv); ) 735 for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
649 { 736 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
650 SV *a = AvARRAY (c->swap_sv)[i++];
651 SV *b = AvARRAY (c->swap_sv)[i++];
652
653 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
654 SV tmp;
655
656 /* swap sv_any */
657 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
658
659 /* swap sv_flags */
660 SvFLAGS (&tmp) = SvFLAGS (a);
661 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
662 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
663
664#if PERL_VERSION_ATLEAST (5,10,0)
665 /* perl 5.10 complicates this _quite_ a bit, but it also is
666 * much faster, so no quarrels here. alternatively, we could
667 * sv_upgrade to avoid this.
668 */
669 {
670 /* swap sv_u */
671 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
672
673 /* if SvANY points to the head, we need to adjust the pointers,
674 * as the pointer for a still points to b, and maybe vice versa.
675 */
676 #define svany_in_head(type) \
677 (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
678
679 if (svany_in_head (SvTYPE (a)))
680 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
681
682 if (svany_in_head (SvTYPE (b)))
683 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
684 }
685#endif
686 }
687} 737}
688 738
739static void
740swap_svs_leave (pTHX_ Coro__State c)
741{
742 int i;
743
744 for (i = AvFILLp (c->swap_sv) - 1; i >= 0; i -= 2)
745 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
746}
747
689#define SWAP_SVS(coro) \ 748#define SWAP_SVS_ENTER(coro) \
690 if (ecb_expect_false ((coro)->swap_sv)) \ 749 if (ecb_expect_false ((coro)->swap_sv)) \
691 swap_svs (aTHX_ (coro)) 750 swap_svs_enter (aTHX_ (coro))
751
752#define SWAP_SVS_LEAVE(coro) \
753 if (ecb_expect_false ((coro)->swap_sv)) \
754 swap_svs_leave (aTHX_ (coro))
692 755
693static void 756static void
694on_enterleave_call (pTHX_ SV *cb); 757on_enterleave_call (pTHX_ SV *cb);
695 758
696static void 759static void
703 766
704#if CORO_JIT 767#if CORO_JIT
705 load_perl_slots (slot); 768 load_perl_slots (slot);
706#else 769#else
707 #define VARx(name,expr,type) expr = slot->name; 770 #define VARx(name,expr,type) expr = slot->name;
708 # include "state.h" 771 #include "state.h"
709 #undef VARx
710#endif 772#endif
711 773
712 { 774 {
713 dSP; 775 dSP;
714 776
717 /* now do the ugly restore mess */ 779 /* now do the ugly restore mess */
718 while (ecb_expect_true (cv = (CV *)POPs)) 780 while (ecb_expect_true (cv = (CV *)POPs))
719 { 781 {
720 put_padlist (aTHX_ cv); /* mark this padlist as available */ 782 put_padlist (aTHX_ cv); /* mark this padlist as available */
721 CvDEPTH (cv) = PTR2IV (POPs); 783 CvDEPTH (cv) = PTR2IV (POPs);
722 CvPADLIST (cv) = (AV *)POPs; 784 CvPADLIST (cv) = (PADLIST *)POPs;
723 } 785 }
724 786
725 PUTBACK; 787 PUTBACK;
726 } 788 }
727 789
742 804
743 for (i = 0; i <= AvFILLp (c->on_enter); ++i) 805 for (i = 0; i <= AvFILLp (c->on_enter); ++i)
744 on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]); 806 on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
745 } 807 }
746 808
809 if (ecb_expect_false (c->on_enter_xs))
810 {
811 int i;
812
813 for (i = 0; i <= AvFILLp (c->on_enter_xs); i += 2)
814 ((coro_enterleave_hook)AvARRAY (c->on_enter_xs)[i]) (aTHX_ AvARRAY (c->on_enter_xs)[i + 1]);
815 }
816
747 SWAP_SVS (c); 817 SWAP_SVS_ENTER (c);
748} 818}
749 819
750static void 820static void
751save_perl (pTHX_ Coro__State c) 821save_perl (pTHX_ Coro__State c)
752{ 822{
753 SWAP_SVS (c); 823 SWAP_SVS_LEAVE (c);
824
825 if (ecb_expect_false (c->on_leave_xs))
826 {
827 int i;
828
829 for (i = AvFILLp (c->on_leave_xs) - 1; i >= 0; i -= 2)
830 ((coro_enterleave_hook)AvARRAY (c->on_leave_xs)[i]) (aTHX_ AvARRAY (c->on_leave_xs)[i + 1]);
831 }
754 832
755 if (ecb_expect_false (c->on_leave)) 833 if (ecb_expect_false (c->on_leave))
756 { 834 {
757 int i; 835 int i;
758 836
817 895
818 PUTBACK; 896 PUTBACK;
819 } 897 }
820 898
821 /* allocate some space on the context stack for our purposes */ 899 /* allocate some space on the context stack for our purposes */
822 if (ecb_expect_false (cxstack_ix + SLOT_COUNT >= cxstack_max)) 900 if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))
823 { 901 {
824 unsigned int i; 902 unsigned int i;
825 903
826 for (i = 0; i < SLOT_COUNT; ++i) 904 for (i = 0; i < SLOT_COUNT; ++i)
827 CXINC; 905 CXINC;
836 914
837#if CORO_JIT 915#if CORO_JIT
838 save_perl_slots (slot); 916 save_perl_slots (slot);
839#else 917#else
840 #define VARx(name,expr,type) slot->name = expr; 918 #define VARx(name,expr,type) slot->name = expr;
841 # include "state.h" 919 #include "state.h"
842 #undef VARx
843#endif 920#endif
844 } 921 }
845} 922}
846 923
847/* 924/*
879#endif 956#endif
880 957
881 New(54,PL_scopestack,8,I32); 958 New(54,PL_scopestack,8,I32);
882 PL_scopestack_ix = 0; 959 PL_scopestack_ix = 0;
883 PL_scopestack_max = 8; 960 PL_scopestack_max = 8;
961#if HAS_SCOPESTACK_NAME
962 New(54,PL_scopestack_name,8,const char*);
963#endif
884 964
885 New(54,PL_savestack,24,ANY); 965 New(54,PL_savestack,24,ANY);
886 PL_savestack_ix = 0; 966 PL_savestack_ix = 0;
887 PL_savestack_max = 24; 967 PL_savestack_max = 24;
968#if !PERL_VERSION_ATLEAST (5,24,0)
969 /* perl 5.24 moves SS_MAXPUSH optimisation from */
970 /* the header macros to PL_savestack_max */
971 PL_savestack_max -= SS_MAXPUSH;
972#endif
888 973
889#if !PERL_VERSION_ATLEAST (5,10,0) 974#if !PERL_VERSION_ATLEAST (5,10,0)
890 New(54,PL_retstack,4,OP*); 975 New(54,PL_retstack,4,OP*);
891 PL_retstack_ix = 0; 976 PL_retstack_ix = 0;
892 PL_retstack_max = 4; 977 PL_retstack_max = 4;
916 } 1001 }
917 1002
918 Safefree (PL_tmps_stack); 1003 Safefree (PL_tmps_stack);
919 Safefree (PL_markstack); 1004 Safefree (PL_markstack);
920 Safefree (PL_scopestack); 1005 Safefree (PL_scopestack);
1006#if HAS_SCOPESTACK_NAME
1007 Safefree (PL_scopestack_name);
1008#endif
921 Safefree (PL_savestack); 1009 Safefree (PL_savestack);
922#if !PERL_VERSION_ATLEAST (5,10,0) 1010#if !PERL_VERSION_ATLEAST (5,10,0)
923 Safefree (PL_retstack); 1011 Safefree (PL_retstack);
924#endif 1012#endif
925} 1013}
985 { 1073 {
986 SV **svp = 0; 1074 SV **svp = 0;
987 1075
988 if (strEQ (s, "__DIE__" )) svp = &PL_diehook; 1076 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
989 if (strEQ (s, "__WARN__")) svp = &PL_warnhook; 1077 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
990 1078
991 if (svp) 1079 if (svp)
992 { 1080 {
993 sv_setsv (sv, *svp ? *svp : &PL_sv_undef); 1081 SV *ssv;
1082
1083 if (!*svp)
1084 ssv = &PL_sv_undef;
1085 else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
1086 ssv = sv_2mortal (newRV_inc (*svp));
1087 else
1088 ssv = *svp;
1089
1090 sv_setsv (sv, ssv);
994 return 0; 1091 return 0;
995 } 1092 }
996 } 1093 }
997 1094
998 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0; 1095 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
1092 PL_hints = 0; 1189 PL_hints = 0;
1093 1190
1094 /* recreate the die/warn hooks */ 1191 /* recreate the die/warn hooks */
1095 PL_diehook = SvREFCNT_inc (rv_diehook); 1192 PL_diehook = SvREFCNT_inc (rv_diehook);
1096 PL_warnhook = SvREFCNT_inc (rv_warnhook); 1193 PL_warnhook = SvREFCNT_inc (rv_warnhook);
1097 1194
1098 GvSV (PL_defgv) = newSV (0); 1195 GvSV (PL_defgv) = newSV (0);
1099 GvAV (PL_defgv) = coro->args; coro->args = 0; 1196 GvAV (PL_defgv) = coro->args; coro->args = 0;
1100 GvSV (PL_errgv) = newSV (0); 1197 GvSV (PL_errgv) = newSV (0);
1101 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0); 1198 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
1102 GvHV (PL_hintgv) = 0; 1199 GvHV (PL_hintgv) = newHV ();
1200#if PERL_VERSION_ATLEAST (5,10,0)
1201 hv_magic (GvHV (PL_hintgv), 0, PERL_MAGIC_hints);
1202#endif
1103 PL_rs = newSVsv (GvSV (irsgv)); 1203 PL_rs = newSVsv (GvSV (irsgv));
1104 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv); 1204 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
1105 1205
1106 { 1206 {
1107 dSP; 1207 dSP;
1135 PL_op = (OP *)&init_perl_op; 1235 PL_op = (OP *)&init_perl_op;
1136 1236
1137 /* copy throw, in case it was set before init_perl */ 1237 /* copy throw, in case it was set before init_perl */
1138 CORO_THROW = coro->except; 1238 CORO_THROW = coro->except;
1139 1239
1140 SWAP_SVS (coro); 1240 SWAP_SVS_ENTER (coro);
1141 1241
1142 if (ecb_expect_false (enable_times)) 1242 if (ecb_expect_false (enable_times))
1143 { 1243 {
1144 coro_times_update (); 1244 coro_times_update ();
1145 coro_times_sub (coro); 1245 coro_times_sub (coro);
1183 /* this will cause transfer_check to croak on block*/ 1283 /* this will cause transfer_check to croak on block*/
1184 SvRV_set (coro_current, (SV *)coro->hv); 1284 SvRV_set (coro_current, (SV *)coro->hv);
1185 1285
1186 load_perl (aTHX_ coro); 1286 load_perl (aTHX_ coro);
1187 1287
1288 /* restore swapped sv's */
1289 SWAP_SVS_LEAVE (coro);
1290
1188 coro_unwind_stacks (aTHX); 1291 coro_unwind_stacks (aTHX);
1189
1190 /* restore swapped sv's */
1191 SWAP_SVS (coro);
1192 1292
1193 coro_destruct_stacks (aTHX); 1293 coro_destruct_stacks (aTHX);
1194 1294
1195 /* now save some sv's to be free'd later */ 1295 /* now save some sv's to be free'd later */
1196 svf [0] = GvSV (PL_defgv); 1296 svf [0] = GvSV (PL_defgv);
1217 1317
1218 SvREFCNT_dec (coro->saved_deffh); 1318 SvREFCNT_dec (coro->saved_deffh);
1219 SvREFCNT_dec (coro->rouse_cb); 1319 SvREFCNT_dec (coro->rouse_cb);
1220 SvREFCNT_dec (coro->invoke_cb); 1320 SvREFCNT_dec (coro->invoke_cb);
1221 SvREFCNT_dec (coro->invoke_av); 1321 SvREFCNT_dec (coro->invoke_av);
1322 SvREFCNT_dec (coro->on_enter_xs);
1323 SvREFCNT_dec (coro->on_leave_xs);
1222 } 1324 }
1223} 1325}
1224 1326
1225ECB_INLINE void 1327ecb_inline void
1226free_coro_mortal (pTHX) 1328free_coro_mortal (pTHX)
1227{ 1329{
1228 if (ecb_expect_true (coro_mortal)) 1330 if (ecb_expect_true (coro_mortal))
1229 { 1331 {
1230 SvREFCNT_dec ((SV *)coro_mortal); 1332 SvREFCNT_dec ((SV *)coro_mortal);
1289 1391
1290 if (PL_curcop != &PL_compiling) 1392 if (PL_curcop != &PL_compiling)
1291 { 1393 {
1292 SV **cb; 1394 SV **cb;
1293 1395
1294 if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB) 1396 if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB && cxstack_ix >= 0)
1295 { 1397 {
1296 PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 1398 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1297 1399
1298 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix) 1400 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
1299 { 1401 {
1389 slf_frame.prepare = slf_prepare_set_stacklevel; 1491 slf_frame.prepare = slf_prepare_set_stacklevel;
1390 slf_frame.check = slf_check_set_stacklevel; 1492 slf_frame.check = slf_check_set_stacklevel;
1391} 1493}
1392 1494
1393/* the tail of transfer: execute stuff we can only do after a transfer */ 1495/* the tail of transfer: execute stuff we can only do after a transfer */
1394ECB_INLINE void 1496ecb_inline void
1395transfer_tail (pTHX) 1497transfer_tail (pTHX)
1396{ 1498{
1397 free_coro_mortal (aTHX); 1499 free_coro_mortal (aTHX);
1500}
1501
1502/* try to exit the same way perl's main function would do */
1503/* we do not bother resetting the environment or other things *7
1504/* that are not, uhm, essential */
1505/* this obviously also doesn't work when perl is embedded */
1506static void ecb_noinline ecb_cold
1507perlish_exit (pTHX)
1508{
1509 int exitstatus = perl_destruct (PL_curinterp);
1510 perl_free (PL_curinterp);
1511 exit (exitstatus);
1398} 1512}
1399 1513
1400/* 1514/*
1401 * this is a _very_ stripped down perl interpreter ;) 1515 * this is a _very_ stripped down perl interpreter ;)
1402 */ 1516 */
1431 */ 1545 */
1432 1546
1433 /* 1547 /*
1434 * If perl-run returns we assume exit() was being called or the coro 1548 * If perl-run returns we assume exit() was being called or the coro
1435 * fell off the end, which seems to be the only valid (non-bug) 1549 * fell off the end, which seems to be the only valid (non-bug)
1436 * reason for perl_run to return. We try to exit by jumping to the 1550 * reason for perl_run to return. We try to mimic whatever perl is normally
1437 * bootstrap-time "top" top_env, as we cannot restore the "main" 1551 * doing in that case. YMMV.
1438 * coroutine as Coro has no such concept.
1439 * This actually isn't valid with the pthread backend, but OSes requiring
1440 * that backend are too broken to do it in a standards-compliant way.
1441 */ 1552 */
1442 PL_top_env = main_top_env; 1553 perlish_exit (aTHX);
1443 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1444 } 1554 }
1445} 1555}
1446 1556
1447static coro_cctx * 1557static coro_cctx *
1448cctx_new (void) 1558cctx_new (void)
1463static coro_cctx * 1573static coro_cctx *
1464cctx_new_empty (void) 1574cctx_new_empty (void)
1465{ 1575{
1466 coro_cctx *cctx = cctx_new (); 1576 coro_cctx *cctx = cctx_new ();
1467 1577
1468 cctx->sptr = 0; 1578 cctx->stack.sptr = 0;
1469 coro_create (&cctx->cctx, 0, 0, 0, 0); 1579 coro_create (&cctx->cctx, 0, 0, 0, 0);
1470 1580
1471 return cctx; 1581 return cctx;
1472} 1582}
1473 1583
1474/* create a new cctx suitable as destination/running a perl interpreter */ 1584/* create a new cctx suitable as destination/running a perl interpreter */
1475static coro_cctx * 1585static coro_cctx *
1476cctx_new_run (void) 1586cctx_new_run (void)
1477{ 1587{
1478 coro_cctx *cctx = cctx_new (); 1588 coro_cctx *cctx = cctx_new ();
1479 void *stack_start;
1480 size_t stack_size;
1481 1589
1482#if HAVE_MMAP 1590 if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1483 cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1484 /* mmap supposedly does allocate-on-write for us */
1485 cctx->sptr = mmap (0, cctx->ssize, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_ANONYMOUS, 0, 0);
1486
1487 if (cctx->sptr != (void *)-1)
1488 {
1489 #if CORO_STACKGUARD
1490 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1491 #endif
1492 stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
1493 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1494 cctx->flags |= CC_MAPPED;
1495 } 1591 {
1496 else
1497#endif
1498 {
1499 cctx->ssize = cctx_stacksize * (long)sizeof (long);
1500 New (0, cctx->sptr, cctx_stacksize, long);
1501
1502 if (!cctx->sptr)
1503 {
1504 perror ("FATAL: unable to allocate stack for coroutine, exiting."); 1592 perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1505 _exit (EXIT_FAILURE); 1593 _exit (EXIT_FAILURE);
1506 }
1507
1508 stack_start = cctx->sptr;
1509 stack_size = cctx->ssize;
1510 } 1594 }
1511 1595
1512 #if CORO_USE_VALGRIND
1513 cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
1514 #endif
1515
1516 coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size); 1596 coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1517 1597
1518 return cctx; 1598 return cctx;
1519} 1599}
1520 1600
1521static void 1601static void
1527 assert (("FATAL: tried to destroy current cctx", cctx != cctx_current)); 1607 assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1528 1608
1529 --cctx_count; 1609 --cctx_count;
1530 coro_destroy (&cctx->cctx); 1610 coro_destroy (&cctx->cctx);
1531 1611
1532 /* coro_transfer creates new, empty cctx's */ 1612 coro_stack_free (&cctx->stack);
1533 if (cctx->sptr)
1534 {
1535 #if CORO_USE_VALGRIND
1536 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1537 #endif
1538
1539#if HAVE_MMAP
1540 if (cctx->flags & CC_MAPPED)
1541 munmap (cctx->sptr, cctx->ssize);
1542 else
1543#endif
1544 Safefree (cctx->sptr);
1545 }
1546 1613
1547 Safefree (cctx); 1614 Safefree (cctx);
1548} 1615}
1549 1616
1550/* wether this cctx should be destructed */ 1617/* wether this cctx should be destructed */
1569} 1636}
1570 1637
1571static void 1638static void
1572cctx_put (coro_cctx *cctx) 1639cctx_put (coro_cctx *cctx)
1573{ 1640{
1574 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr)); 1641 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1575 1642
1576 /* free another cctx if overlimit */ 1643 /* free another cctx if overlimit */
1577 if (ecb_expect_false (cctx_idle >= cctx_max_idle)) 1644 if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1578 { 1645 {
1579 coro_cctx *first = cctx_first; 1646 coro_cctx *first = cctx_first;
1705 return; 1772 return;
1706 1773
1707 slf_destroy (aTHX_ coro); 1774 slf_destroy (aTHX_ coro);
1708 1775
1709 coro->flags |= CF_ZOMBIE; 1776 coro->flags |= CF_ZOMBIE;
1710 1777
1711 if (coro->flags & CF_READY) 1778 if (coro->flags & CF_READY)
1712 { 1779 {
1713 /* reduce nready, as destroying a ready coro effectively unreadies it */ 1780 /* reduce nready, as destroying a ready coro effectively unreadies it */
1714 /* alternative: look through all ready queues and remove the coro */ 1781 /* alternative: look through all ready queues and remove the coro */
1715 --coro_nready; 1782 --coro_nready;
1792 TRANSFER (ta, 1); 1859 TRANSFER (ta, 1);
1793} 1860}
1794 1861
1795/** Coro ********************************************************************/ 1862/** Coro ********************************************************************/
1796 1863
1797ECB_INLINE void 1864ecb_inline void
1798coro_enq (pTHX_ struct coro *coro) 1865coro_enq (pTHX_ struct coro *coro)
1799{ 1866{
1800 struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN]; 1867 struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1801 1868
1802 SvREFCNT_inc_NN (coro->hv); 1869 SvREFCNT_inc_NN (coro->hv);
1804 coro->next_ready = 0; 1871 coro->next_ready = 0;
1805 *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro; 1872 *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1806 ready [1] = coro; 1873 ready [1] = coro;
1807} 1874}
1808 1875
1809ECB_INLINE struct coro * 1876ecb_inline struct coro *
1810coro_deq (pTHX) 1877coro_deq (pTHX)
1811{ 1878{
1812 int prio; 1879 int prio;
1813 1880
1814 for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; ) 1881 for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1867{ 1934{
1868 return !!(SvSTATE (coro_sv)->flags & CF_READY); 1935 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1869} 1936}
1870 1937
1871/* expects to own a reference to next->hv */ 1938/* expects to own a reference to next->hv */
1872ECB_INLINE void 1939ecb_inline void
1873prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next) 1940prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1874{ 1941{
1875 SV *prev_sv = SvRV (coro_current); 1942 SV *prev_sv = SvRV (coro_current);
1876 1943
1877 ta->prev = SvSTATE_hv (prev_sv); 1944 ta->prev = SvSTATE_hv (prev_sv);
1911 /* nothing to schedule: call the idle handler */ 1978 /* nothing to schedule: call the idle handler */
1912 if (SvROK (sv_idle) 1979 if (SvROK (sv_idle)
1913 && SvOBJECT (SvRV (sv_idle))) 1980 && SvOBJECT (SvRV (sv_idle)))
1914 { 1981 {
1915 if (SvRV (sv_idle) == SvRV (coro_current)) 1982 if (SvRV (sv_idle) == SvRV (coro_current))
1983 {
1984 require_pv ("Carp");
1985
1986 {
1987 dSP;
1988
1989 ENTER;
1990 SAVETMPS;
1991
1992 PUSHMARK (SP);
1916 croak ("FATAL: $Coro::IDLE blocked itself - did you try to block inside an event loop callback? Caught"); 1993 XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0)));
1994 PUTBACK;
1995 call_pv ("Carp::confess", G_VOID | G_DISCARD);
1996
1997 FREETMPS;
1998 LEAVE;
1999 }
2000 }
1917 2001
1918 ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */ 2002 ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
1919 api_ready (aTHX_ SvRV (sv_idle)); 2003 api_ready (aTHX_ SvRV (sv_idle));
1920 --coro_nready; 2004 --coro_nready;
1921 } 2005 }
1936 } 2020 }
1937 } 2021 }
1938 } 2022 }
1939} 2023}
1940 2024
1941ECB_INLINE void 2025ecb_inline void
1942prepare_cede (pTHX_ struct coro_transfer_args *ta) 2026prepare_cede (pTHX_ struct coro_transfer_args *ta)
1943{ 2027{
1944 api_ready (aTHX_ coro_current); 2028 api_ready (aTHX_ coro_current);
1945 prepare_schedule (aTHX_ ta); 2029 prepare_schedule (aTHX_ ta);
1946} 2030}
1947 2031
1948ECB_INLINE void 2032ecb_inline void
1949prepare_cede_notself (pTHX_ struct coro_transfer_args *ta) 2033prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1950{ 2034{
1951 SV *prev = SvRV (coro_current); 2035 SV *prev = SvRV (coro_current);
1952 2036
1953 if (coro_nready) 2037 if (coro_nready)
2118{ 2202{
2119 AV *od = coro->on_destroy; 2203 AV *od = coro->on_destroy;
2120 2204
2121 if (!od) 2205 if (!od)
2122 return; 2206 return;
2207
2208 coro->on_destroy = 0;
2209 sv_2mortal ((SV *)od);
2123 2210
2124 while (AvFILLp (od) >= 0) 2211 while (AvFILLp (od) >= 0)
2125 { 2212 {
2126 SV *cb = sv_2mortal (av_pop (od)); 2213 SV *cb = sv_2mortal (av_pop (od));
2127 2214
2148 2235
2149static void 2236static void
2150coro_set_status (pTHX_ struct coro *coro, SV **arg, int items) 2237coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
2151{ 2238{
2152 AV *av; 2239 AV *av;
2153 2240
2154 if (coro->status) 2241 if (coro->status)
2155 { 2242 {
2156 av = coro->status; 2243 av = coro->status;
2157 av_clear (av); 2244 av_clear (av);
2158 } 2245 }
2205 2292
2206 coro = SvSTATE (arg [0]); 2293 coro = SvSTATE (arg [0]);
2207 coro_hv = coro->hv; 2294 coro_hv = coro->hv;
2208 2295
2209 coro_set_status (aTHX_ coro, arg + 1, items - 1); 2296 coro_set_status (aTHX_ coro, arg + 1, items - 1);
2210 2297
2211 if (ecb_expect_false (coro->flags & CF_NOCANCEL)) 2298 if (ecb_expect_false (coro->flags & CF_NOCANCEL))
2212 { 2299 {
2213 /* coro currently busy cancelling something, so just notify it */ 2300 /* coro currently busy cancelling something, so just notify it */
2214 coro->slf_frame.data = (void *)coro; 2301 coro->slf_frame.data = (void *)coro;
2215 2302
2222 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv); 2309 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2223 } 2310 }
2224 else 2311 else
2225 { 2312 {
2226 struct coro *self = SvSTATE_current; 2313 struct coro *self = SvSTATE_current;
2314
2315 if (!self)
2316 croak ("Coro::cancel called outside of thread content,");
2227 2317
2228 /* otherwise we cancel directly, purely for speed reasons 2318 /* otherwise we cancel directly, purely for speed reasons
2229 * unfortunately, this requires some magic trickery, as 2319 * unfortunately, this requires some magic trickery, as
2230 * somebody else could cancel us, so we have to fight the cancellation. 2320 * somebody else could cancel us, so we have to fight the cancellation.
2231 * this is ugly, and hopefully fully worth the extra speed. 2321 * this is ugly, and hopefully fully worth the extra speed.
2341 else 2431 else
2342 { 2432 {
2343 av_clear (GvAV (PL_defgv)); 2433 av_clear (GvAV (PL_defgv));
2344 hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0); 2434 hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
2345 2435
2436 if (ecb_expect_false (coro->swap_sv))
2437 {
2438 swap_svs_leave (coro);
2439 SvREFCNT_dec_NN (coro->swap_sv);
2440 coro->swap_sv = 0;
2441 }
2442
2346 coro->prio = 0; 2443 coro->prio = 0;
2347 2444
2348 if (coro->cctx && (coro->cctx->flags & CC_TRACE)) 2445 if (ecb_expect_false (coro->cctx) && ecb_expect_false (coro->cctx->flags & CC_TRACE))
2349 api_trace (aTHX_ coro_current, 0); 2446 api_trace (aTHX_ coro_current, 0);
2350 2447
2351 frame->prepare = prepare_schedule; 2448 frame->prepare = prepare_schedule;
2352 av_push (av_async_pool, SvREFCNT_inc (hv)); 2449 av_push (av_async_pool, SvREFCNT_inc (hv));
2353 } 2450 }
2394 2491
2395static int 2492static int
2396slf_check_rouse_wait (pTHX_ struct CoroSLF *frame) 2493slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2397{ 2494{
2398 SV *data = (SV *)frame->data; 2495 SV *data = (SV *)frame->data;
2399 2496
2400 if (CORO_THROW) 2497 if (CORO_THROW)
2401 return 0; 2498 return 0;
2402 2499
2403 if (SvTYPE (SvRV (data)) != SVt_PVAV) 2500 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2404 return 1; 2501 return 1;
2440 cb = sv_2mortal (coro->rouse_cb); 2537 cb = sv_2mortal (coro->rouse_cb);
2441 coro->rouse_cb = 0; 2538 coro->rouse_cb = 0;
2442 } 2539 }
2443 2540
2444 if (!SvROK (cb) 2541 if (!SvROK (cb)
2445 || SvTYPE (SvRV (cb)) != SVt_PVCV 2542 || SvTYPE (SvRV (cb)) != SVt_PVCV
2446 || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback) 2543 || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2447 croak ("Coro::rouse_wait called with illegal callback argument,"); 2544 croak ("Coro::rouse_wait called with illegal callback argument,");
2448 2545
2449 { 2546 {
2450 CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */ 2547 CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2573 2670
2574/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */ 2671/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
2575static void 2672static void
2576slf_destroy (pTHX_ struct coro *coro) 2673slf_destroy (pTHX_ struct coro *coro)
2577{ 2674{
2578 /* this callback is reserved for slf functions needing to do cleanup */ 2675 struct CoroSLF frame = coro->slf_frame;
2579 if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)
2580 coro->slf_frame.destroy (aTHX_ &coro->slf_frame);
2581 2676
2582 /* 2677 /*
2583 * The on_destroy above most likely is from an SLF call. 2678 * The on_destroy below most likely is from an SLF call.
2584 * Since by definition the SLF call will not finish when we destroy 2679 * Since by definition the SLF call will not finish when we destroy
2585 * the coro, we will have to force-finish it here, otherwise 2680 * the coro, we will have to force-finish it here, otherwise
2586 * cleanup functions cannot call SLF functions. 2681 * cleanup functions cannot call SLF functions.
2587 */ 2682 */
2588 coro->slf_frame.prepare = 0; 2683 coro->slf_frame.prepare = 0;
2684
2685 /* this callback is reserved for slf functions needing to do cleanup */
2686 if (frame.destroy && frame.prepare && !PL_dirty)
2687 frame.destroy (aTHX_ &frame);
2589} 2688}
2590 2689
2591/* 2690/*
2592 * these not obviously related functions are all rolled into one 2691 * these not obviously related functions are all rolled into one
2593 * function to increase chances that they all will call transfer with the same 2692 * function to increase chances that they all will call transfer with the same
2776static void 2875static void
2777coro_pop_on_leave (pTHX_ void *coro) 2876coro_pop_on_leave (pTHX_ void *coro)
2778{ 2877{
2779 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave); 2878 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave);
2780 on_enterleave_call (aTHX_ sv_2mortal (cb)); 2879 on_enterleave_call (aTHX_ sv_2mortal (cb));
2880}
2881
2882static void
2883enterleave_hook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, void *arg)
2884{
2885 if (!hook)
2886 return;
2887
2888 if (!*avp)
2889 {
2890 *avp = newAV ();
2891 AvREAL_off (*avp);
2892 }
2893
2894 av_push (*avp, (SV *)hook);
2895 av_push (*avp, (SV *)arg);
2896}
2897
2898static void
2899enterleave_unhook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, int execute)
2900{
2901 AV *av = *avp;
2902 int i;
2903
2904 if (!av)
2905 return;
2906
2907 for (i = AvFILLp (av) - 1; i >= 0; i -= 2)
2908 if (AvARRAY (av)[i] == (SV *)hook)
2909 {
2910 if (execute)
2911 hook (aTHX_ (void *)AvARRAY (av)[i + 1]);
2912
2913 memmove (AvARRAY (av) + i, AvARRAY (av) + i + 2, AvFILLp (av) - i - 1);
2914 av_pop (av);
2915 av_pop (av);
2916 break;
2917 }
2918
2919 if (AvFILLp (av) >= 0)
2920 {
2921 *avp = 0;
2922 SvREFCNT_dec_NN (av);
2923 }
2924}
2925
2926static void
2927api_enterleave_hook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
2928{
2929 struct coro *coro = SvSTATE (coro_sv);
2930
2931 if (SvSTATE_current == coro)
2932 if (enter)
2933 enter (aTHX_ enter_arg);
2934
2935 enterleave_hook_xs (aTHX_ coro, &coro->on_enter_xs, enter, enter_arg);
2936 enterleave_hook_xs (aTHX_ coro, &coro->on_leave_xs, leave, leave_arg);
2937}
2938
2939static void
2940api_enterleave_unhook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave)
2941{
2942 struct coro *coro = SvSTATE (coro_sv);
2943
2944 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2945 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, SvSTATE_current == coro);
2946}
2947
2948static void
2949savedestructor_unhook_enter (pTHX_ coro_enterleave_hook enter)
2950{
2951 struct coro *coro = SvSTATE_current;
2952
2953 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2954}
2955
2956static void
2957savedestructor_unhook_leave (pTHX_ coro_enterleave_hook leave)
2958{
2959 struct coro *coro = SvSTATE_current;
2960
2961 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, 1);
2962}
2963
2964static void
2965api_enterleave_scope_hook (pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
2966{
2967 api_enterleave_hook (aTHX_ coro_current, enter, enter_arg, leave, leave_arg);
2968
2969 /* this ought to be much cheaper than malloc + a single destructor call */
2970 if (enter) SAVEDESTRUCTOR_X (savedestructor_unhook_enter, enter);
2971 if (leave) SAVEDESTRUCTOR_X (savedestructor_unhook_leave, leave);
2781} 2972}
2782 2973
2783/*****************************************************************************/ 2974/*****************************************************************************/
2784/* PerlIO::cede */ 2975/* PerlIO::cede */
2785 2976
2915 XPUSHs (sv_2mortal (newRV_inc ((SV *)av))); 3106 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
2916 PUTBACK; 3107 PUTBACK;
2917 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR); 3108 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
2918 } 3109 }
2919 3110
2920 SvREFCNT_dec (cb); 3111 SvREFCNT_dec_NN (cb);
2921 } 3112 }
2922} 3113}
2923 3114
2924static void 3115static void
2925coro_semaphore_destroy (pTHX_ struct CoroSLF *frame) 3116coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
2933{ 3124{
2934 AV *av = (AV *)frame->data; 3125 AV *av = (AV *)frame->data;
2935 SV *count_sv = AvARRAY (av)[0]; 3126 SV *count_sv = AvARRAY (av)[0];
2936 SV *coro_hv = SvRV (coro_current); 3127 SV *coro_hv = SvRV (coro_current);
2937 3128
3129 frame->destroy = 0;
3130
2938 /* if we are about to throw, don't actually acquire the lock, just throw */ 3131 /* if we are about to throw, don't actually acquire the lock, just throw */
2939 if (CORO_THROW) 3132 if (ecb_expect_false (CORO_THROW))
3133 {
3134 /* we still might be responsible for the semaphore, so wake up others */
3135 coro_semaphore_adjust (aTHX_ av, 0);
3136
2940 return 0; 3137 return 0;
3138 }
2941 else if (SvIVX (count_sv) > 0) 3139 else if (SvIVX (count_sv) > 0)
2942 { 3140 {
2943 frame->destroy = 0;
2944
2945 if (acquire) 3141 if (acquire)
2946 SvIVX (count_sv) = SvIVX (count_sv) - 1; 3142 SvIVX (count_sv) = SvIVX (count_sv) - 1;
2947 else 3143 else
2948 coro_semaphore_adjust (aTHX_ av, 0); 3144 coro_semaphore_adjust (aTHX_ av, 0);
2949 3145
3060 { 3256 {
3061 api_ready (aTHX_ cb); 3257 api_ready (aTHX_ cb);
3062 sv_setiv (cb, 0); /* signal waiter */ 3258 sv_setiv (cb, 0); /* signal waiter */
3063 } 3259 }
3064 3260
3065 SvREFCNT_dec (cb); 3261 SvREFCNT_dec_NN (cb);
3066 3262
3067 --count; 3263 --count;
3068 } 3264 }
3069} 3265}
3070 3266
3155 } 3351 }
3156 3352
3157 av_push (state, data_sv); 3353 av_push (state, data_sv);
3158 3354
3159 api_ready (aTHX_ coro); 3355 api_ready (aTHX_ coro);
3160 SvREFCNT_dec (coro); 3356 SvREFCNT_dec_NN (coro);
3161 SvREFCNT_dec ((AV *)state); 3357 SvREFCNT_dec_NN ((AV *)state);
3162} 3358}
3163 3359
3164static int 3360static int
3165slf_check_aio_req (pTHX_ struct CoroSLF *frame) 3361slf_check_aio_req (pTHX_ struct CoroSLF *frame)
3166{ 3362{
3171 /* it quickly returns */ 3367 /* it quickly returns */
3172 if (CORO_THROW) 3368 if (CORO_THROW)
3173 return 0; 3369 return 0;
3174 3370
3175 /* one element that is an RV? repeat! */ 3371 /* one element that is an RV? repeat! */
3176 if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0])) 3372 if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
3177 return 1; 3373 return 1;
3178 3374
3179 /* restore status */ 3375 /* restore status */
3180 { 3376 {
3181 SV *data_sv = av_pop (state); 3377 SV *data_sv = av_pop (state);
3184 errno = data->errorno; 3380 errno = data->errorno;
3185 PL_laststype = data->laststype; 3381 PL_laststype = data->laststype;
3186 PL_laststatval = data->laststatval; 3382 PL_laststatval = data->laststatval;
3187 PL_statcache = data->statcache; 3383 PL_statcache = data->statcache;
3188 3384
3189 SvREFCNT_dec (data_sv); 3385 SvREFCNT_dec_NN (data_sv);
3190 } 3386 }
3191 3387
3192 /* push result values */ 3388 /* push result values */
3193 { 3389 {
3194 dSP; 3390 dSP;
3343#endif 3539#endif
3344 3540
3345#if CORO_JIT 3541#if CORO_JIT
3346 3542
3347static void ecb_noinline ecb_cold 3543static void ecb_noinline ecb_cold
3348pushav_3uv (pTHX_ UV a, UV b, UV c) 3544pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
3349{ 3545{
3350 dSP; 3546 dSP;
3351 AV *av = newAV (); 3547 AV *av = newAV ();
3352 3548
3549 av_store (av, 3, newSVuv (d));
3353 av_store (av, 2, newSVuv (c)); 3550 av_store (av, 2, newSVuv (c));
3354 av_store (av, 1, newSVuv (b)); 3551 av_store (av, 1, newSVuv (b));
3355 av_store (av, 0, newSVuv (a)); 3552 av_store (av, 0, newSVuv (a));
3356 3553
3357 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av))); 3554 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
3370 int count; 3567 int count;
3371 3568
3372 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1); 3569 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
3373 3570
3374 PUSHMARK (SP); 3571 PUSHMARK (SP);
3375#define VARx(name,expr,type) pushav_3uv (aTHX_ (UV)&(expr), offsetof (perl_slots, name), sizeof (type)); 3572 #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
3376# include "state.h" 3573 #include "state.h"
3377#undef VARx
3378 count = call_pv ("Coro::State::_jit", G_ARRAY); 3574 count = call_pv ("Coro::State::_jit", G_ARRAY);
3379 SPAGAIN; 3575 SPAGAIN;
3380 3576
3381 save = POPs; save_ptr = SvPVbyte (save, save_len); 3577 save = POPs; save_ptr = SvPVbyte (save, save_len);
3382 load = POPs; load_ptr = SvPVbyte (load, load_len); 3578 load = POPs; load_ptr = SvPVbyte (load, load_len);
3409 3605
3410PROTOTYPES: DISABLE 3606PROTOTYPES: DISABLE
3411 3607
3412BOOT: 3608BOOT:
3413{ 3609{
3610#define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl.");
3611#include "state.h"
3414#ifdef USE_ITHREADS 3612#ifdef USE_ITHREADS
3415# if CORO_PTHREAD 3613# if CORO_PTHREAD
3416 coro_thx = PERL_GET_CONTEXT; 3614 coro_thx = PERL_GET_CONTEXT;
3417# endif 3615# endif
3418#endif 3616#endif
3419 BOOT_PAGESIZE;
3420
3421 /* perl defines these to check for existance first, but why it doesn't */ 3617 /* perl defines these to check for existance first, but why it doesn't */
3422 /* just create them one at init time is not clear to me, except for */ 3618 /* just create them one at init time is not clear to me, except for */
3423 /* programs trying to delete them, but... */ 3619 /* programs trying to delete them, but... */
3424 /* anyway, we declare this as invalid and make sure they are initialised here */ 3620 /* anyway, we declare this as invalid and make sure they are initialised here */
3425 DEFSV; 3621 DEFSV;
3432 3628
3433 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get; 3629 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
3434 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set; 3630 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
3435 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr; 3631 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
3436 3632
3437 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
3438 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV)); 3633 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
3439 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV)); 3634 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
3440 3635
3441 coro_state_stash = gv_stashpv ("Coro::State", TRUE); 3636 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
3442 3637
3495void 3690void
3496transfer (...) 3691transfer (...)
3497 PROTOTYPE: $$ 3692 PROTOTYPE: $$
3498 CODE: 3693 CODE:
3499 CORO_EXECUTE_SLF_XS (slf_init_transfer); 3694 CORO_EXECUTE_SLF_XS (slf_init_transfer);
3500
3501void
3502_exit (int code)
3503 PROTOTYPE: $
3504 CODE:
3505 _exit (code);
3506 3695
3507SV * 3696SV *
3508clone (Coro::State coro) 3697clone (Coro::State coro)
3509 CODE: 3698 CODE:
3510{ 3699{
3565void 3754void
3566list () 3755list ()
3567 PROTOTYPE: 3756 PROTOTYPE:
3568 PPCODE: 3757 PPCODE:
3569{ 3758{
3570 struct coro *coro; 3759 struct coro *coro;
3571 for (coro = coro_first; coro; coro = coro->next) 3760 for (coro = coro_first; coro; coro = coro->next)
3572 if (coro->hv) 3761 if (coro->hv)
3573 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv))); 3762 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3574} 3763}
3575 3764
3639 RETVAL = boolSV (coro->flags & ix); 3828 RETVAL = boolSV (coro->flags & ix);
3640 OUTPUT: 3829 OUTPUT:
3641 RETVAL 3830 RETVAL
3642 3831
3643void 3832void
3644throw (Coro::State self, SV *exception = &PL_sv_undef) 3833throw (SV *self, SV *exception = &PL_sv_undef)
3645 PROTOTYPE: $;$ 3834 PROTOTYPE: $;$
3646 CODE: 3835 CODE:
3647{ 3836{
3837 struct coro *coro = SvSTATE (self);
3648 struct coro *current = SvSTATE_current; 3838 struct coro *current = SvSTATE_current;
3649 SV **exceptionp = self == current ? &CORO_THROW : &self->except; 3839 SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3650 SvREFCNT_dec (*exceptionp); 3840 SvREFCNT_dec (*exceptionp);
3651 SvGETMAGIC (exception); 3841 SvGETMAGIC (exception);
3652 *exceptionp = SvOK (exception) ? newSVsv (exception) : 0; 3842 *exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
3843
3844 api_ready (aTHX_ self);
3653} 3845}
3654 3846
3655void 3847void
3656api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB) 3848api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3657 PROTOTYPE: $;$ 3849 PROTOTYPE: $;$
3734 3926
3735void 3927void
3736times (Coro::State self) 3928times (Coro::State self)
3737 PPCODE: 3929 PPCODE:
3738{ 3930{
3739 struct coro *current = SvSTATE (coro_current); 3931 struct coro *current = SvSTATE (coro_current);
3740 3932
3741 if (ecb_expect_false (current == self)) 3933 if (ecb_expect_false (current == self))
3742 { 3934 {
3743 coro_times_update (); 3935 coro_times_update ();
3744 coro_times_add (SvSTATE (coro_current)); 3936 coro_times_add (SvSTATE (coro_current));
3751 if (ecb_expect_false (current == self)) 3943 if (ecb_expect_false (current == self))
3752 coro_times_sub (SvSTATE (coro_current)); 3944 coro_times_sub (SvSTATE (coro_current));
3753} 3945}
3754 3946
3755void 3947void
3756swap_sv (Coro::State coro, SV *sv, SV *swapsv) 3948swap_sv (Coro::State coro, SV *sva, SV *svb)
3757 CODE: 3949 CODE:
3758{ 3950{
3759 struct coro *current = SvSTATE_current; 3951 struct coro *current = SvSTATE_current;
3952 AV *swap_sv;
3953 int i;
3954
3955 sva = SvRV (sva);
3956 svb = SvRV (svb);
3760 3957
3761 if (current == coro) 3958 if (current == coro)
3762 SWAP_SVS (current); 3959 SWAP_SVS_LEAVE (current);
3763 3960
3764 if (!coro->swap_sv) 3961 if (!coro->swap_sv)
3765 coro->swap_sv = newAV (); 3962 coro->swap_sv = newAV ();
3766 3963
3964 swap_sv = coro->swap_sv;
3965
3966 for (i = AvFILLp (swap_sv) - 1; i >= 0; i -= 2)
3967 {
3968 SV *a = AvARRAY (swap_sv)[i ];
3969 SV *b = AvARRAY (swap_sv)[i + 1];
3970
3971 if (a == sva && b == svb)
3972 {
3973 SvREFCNT_dec_NN (a);
3974 SvREFCNT_dec_NN (b);
3975
3976 for (; i <= AvFILLp (swap_sv) - 2; i++)
3977 AvARRAY (swap_sv)[i] = AvARRAY (swap_sv)[i + 2];
3978
3979 AvFILLp (swap_sv) -= 2;
3980
3981 goto removed;
3982 }
3983 }
3984
3767 av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv ))); 3985 av_push (swap_sv, SvREFCNT_inc_NN (sva));
3768 av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv))); 3986 av_push (swap_sv, SvREFCNT_inc_NN (svb));
3987
3988 removed:
3769 3989
3770 if (current == coro) 3990 if (current == coro)
3771 SWAP_SVS (current); 3991 SWAP_SVS_ENTER (current);
3772} 3992}
3773 3993
3774 3994
3775MODULE = Coro::State PACKAGE = Coro 3995MODULE = Coro::State PACKAGE = Coro
3776 3996
3777BOOT: 3997BOOT:
3778{ 3998{
3999 if (SVt_LAST > 32)
4000 croak ("Coro internal error: SVt_LAST > 32, swap_sv might need adjustment");
4001
3779 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE); 4002 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
3780 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE); 4003 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
3781 cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD); 4004 cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
3782 coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current); 4005 coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
3783 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE); 4006 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
3787 4010
3788 sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle); 4011 sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
3789 sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro); 4012 sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
3790 cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler); 4013 cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
3791 CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */ 4014 CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
3792 4015
3793 coro_stash = gv_stashpv ("Coro", TRUE); 4016 coro_stash = gv_stashpv ("Coro", TRUE);
3794 4017
3795 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX)); 4018 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
3796 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH)); 4019 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
3797 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL)); 4020 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
3809 coroapi.ready = api_ready; 4032 coroapi.ready = api_ready;
3810 coroapi.is_ready = api_is_ready; 4033 coroapi.is_ready = api_is_ready;
3811 coroapi.nready = coro_nready; 4034 coroapi.nready = coro_nready;
3812 coroapi.current = coro_current; 4035 coroapi.current = coro_current;
3813 4036
4037 coroapi.enterleave_hook = api_enterleave_hook;
4038 coroapi.enterleave_unhook = api_enterleave_unhook;
4039 coroapi.enterleave_scope_hook = api_enterleave_scope_hook;
4040
3814 /*GCoroAPI = &coroapi;*/ 4041 /*GCoroAPI = &coroapi;*/
3815 sv_setiv (sv, (IV)&coroapi); 4042 sv_setiv (sv, (IV)&coroapi);
3816 SvREADONLY_on (sv); 4043 SvREADONLY_on (sv);
3817 } 4044 }
3818} 4045}
3883 4110
3884void 4111void
3885_set_current (SV *current) 4112_set_current (SV *current)
3886 PROTOTYPE: $ 4113 PROTOTYPE: $
3887 CODE: 4114 CODE:
3888 SvREFCNT_dec (SvRV (coro_current)); 4115 SvREFCNT_dec_NN (SvRV (coro_current));
3889 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current))); 4116 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
3890 4117
3891void 4118void
3892_set_readyhook (SV *hook) 4119_set_readyhook (SV *hook)
3893 PROTOTYPE: $ 4120 PROTOTYPE: $
3977 4204
3978 if ((SV *)hv == &PL_sv_undef) 4205 if ((SV *)hv == &PL_sv_undef)
3979 { 4206 {
3980 SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1); 4207 SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
3981 hv = (HV *)SvREFCNT_inc_NN (SvRV (sv)); 4208 hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
3982 SvREFCNT_dec (sv); 4209 SvREFCNT_dec_NN (sv);
3983 } 4210 }
3984 4211
3985 { 4212 {
3986 struct coro *coro = SvSTATE_hv (hv); 4213 struct coro *coro = SvSTATE_hv (hv);
3987 4214
3994 api_ready (aTHX_ (SV *)hv); 4221 api_ready (aTHX_ (SV *)hv);
3995 4222
3996 if (GIMME_V != G_VOID) 4223 if (GIMME_V != G_VOID)
3997 XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv))); 4224 XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv)));
3998 else 4225 else
3999 SvREFCNT_dec (hv); 4226 SvREFCNT_dec_NN (hv);
4000} 4227}
4001 4228
4002SV * 4229SV *
4003rouse_cb () 4230rouse_cb ()
4004 PROTOTYPE: 4231 PROTOTYPE:
4019 on_leave = 1 4246 on_leave = 1
4020 PROTOTYPE: & 4247 PROTOTYPE: &
4021 CODE: 4248 CODE:
4022{ 4249{
4023 struct coro *coro = SvSTATE_current; 4250 struct coro *coro = SvSTATE_current;
4024 AV **avp = ix ? &coro->on_leave : &coro->on_enter; 4251 AV **avp = ix ? &coro->on_leave : &coro->on_enter;
4025 4252
4026 block = s_get_cv_croak (block); 4253 block = s_get_cv_croak (block);
4027 4254
4028 if (!*avp) 4255 if (!*avp)
4029 *avp = newAV (); 4256 *avp = newAV ();
4049 4276
4050SV * 4277SV *
4051new (SV *klass, SV *count = 0) 4278new (SV *klass, SV *count = 0)
4052 CODE: 4279 CODE:
4053{ 4280{
4054 int semcnt = 1; 4281 int semcnt = 1;
4055 4282
4056 if (count) 4283 if (count)
4057 { 4284 {
4058 SvGETMAGIC (count); 4285 SvGETMAGIC (count);
4059 4286
4083 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]); 4310 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
4084 OUTPUT: 4311 OUTPUT:
4085 RETVAL 4312 RETVAL
4086 4313
4087void 4314void
4088up (SV *self, int adjust = 1) 4315up (SV *self)
4089 ALIAS:
4090 adjust = 1
4091 CODE: 4316 CODE:
4317 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), 1);
4318
4319void
4320adjust (SV *self, int adjust)
4321 CODE:
4092 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), ix ? adjust : 1); 4322 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), adjust);
4093 4323
4094void 4324void
4095down (...) 4325down (...)
4096 CODE: 4326 CODE:
4097 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down); 4327 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
4119 XSRETURN_NO; 4349 XSRETURN_NO;
4120} 4350}
4121 4351
4122void 4352void
4123waiters (SV *self) 4353waiters (SV *self)
4124 PPCODE: 4354 PPCODE:
4125{ 4355{
4126 AV *av = (AV *)SvRV (self); 4356 AV *av = (AV *)SvRV (self);
4127 int wcount = AvFILLp (av) + 1 - 1; 4357 int wcount = AvFILLp (av) + 1 - 1;
4128 4358
4129 if (GIMME_V == G_SCALAR) 4359 if (GIMME_V == G_SCALAR)
4138} 4368}
4139 4369
4140MODULE = Coro::State PACKAGE = Coro::SemaphoreSet 4370MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
4141 4371
4142void 4372void
4143_may_delete (SV *sem, int count, int extra_refs) 4373_may_delete (SV *sem, int count, unsigned int extra_refs)
4144 PPCODE: 4374 PPCODE:
4145{ 4375{
4146 AV *av = (AV *)SvRV (sem); 4376 AV *av = (AV *)SvRV (sem);
4147 4377
4148 if (SvREFCNT ((SV *)av) == 1 + extra_refs 4378 if (SvREFCNT ((SV *)av) == 1 + extra_refs
4149 && AvFILLp (av) == 0 /* no waiters, just count */ 4379 && AvFILLp (av) == 0 /* no waiters, just count */
4150 && SvIV (AvARRAY (av)[0]) == count) 4380 && SvIV (AvARRAY (av)[0]) == count)
4151 XSRETURN_YES; 4381 XSRETURN_YES;
4172 4402
4173void 4403void
4174broadcast (SV *self) 4404broadcast (SV *self)
4175 CODE: 4405 CODE:
4176{ 4406{
4177 AV *av = (AV *)SvRV (self); 4407 AV *av = (AV *)SvRV (self);
4178 coro_signal_wake (aTHX_ av, AvFILLp (av)); 4408 coro_signal_wake (aTHX_ av, AvFILLp (av));
4179} 4409}
4180 4410
4181void 4411void
4182send (SV *self) 4412send (SV *self)
4190 SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */ 4420 SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
4191} 4421}
4192 4422
4193IV 4423IV
4194awaited (SV *self) 4424awaited (SV *self)
4195 CODE: 4425 CODE:
4196 RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1; 4426 RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
4197 OUTPUT: 4427 OUTPUT:
4198 RETVAL 4428 RETVAL
4199 4429
4200 4430
4205 4435
4206void 4436void
4207_schedule (...) 4437_schedule (...)
4208 CODE: 4438 CODE:
4209{ 4439{
4210 static int incede; 4440 static int incede;
4211 4441
4212 api_cede_notself (aTHX); 4442 api_cede_notself (aTHX);
4213 4443
4214 ++incede; 4444 ++incede;
4215 while (coro_nready >= incede && api_cede (aTHX)) 4445 while (coro_nready >= incede && api_cede (aTHX))
4259 { 4489 {
4260 PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect; 4490 PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
4261 coro_old_pp_sselect = 0; 4491 coro_old_pp_sselect = 0;
4262 } 4492 }
4263 4493
4494MODULE = Coro::State PACKAGE = Coro::Util
4495
4496void
4497_exit (int code)
4498 CODE:
4499 _exit (code);
4500
4501NV
4502time ()
4503 CODE:
4504 RETVAL = nvtime (aTHX);
4505 OUTPUT:
4506 RETVAL
4507
4508NV
4509gettimeofday ()
4510 PPCODE:
4511{
4512 UV tv [2];
4513 u2time (aTHX_ tv);
4514 EXTEND (SP, 2);
4515 PUSHs (sv_2mortal (newSVuv (tv [0])));
4516 PUSHs (sv_2mortal (newSVuv (tv [1])));
4517}
4518

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines