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.415 by root, Tue Aug 30 07:48:53 2011 UTC vs.
Revision 1.420 by root, Fri Apr 13 10:53:25 2012 UTC

… …
101# if CORO_PTHREAD 101# if CORO_PTHREAD
102static void *coro_thx; 102static void *coro_thx;
103# endif 103# endif
104#endif 104#endif
105 105
106/* used in state.h */
107#define VAR(name,type) VARx(name, PL_ ## name, type)
108
109#ifdef __linux 106#ifdef __linux
110# include <time.h> /* for timespec */ 107# include <time.h> /* for timespec */
111# include <syscall.h> /* for SYS_* */ 108# include <syscall.h> /* for SYS_* */
112# ifdef SYS_clock_gettime 109# ifdef SYS_clock_gettime
113# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts)) 110# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
… …
181 void *sptr; 178 void *sptr;
182 size_t ssize; 179 size_t ssize;
183 180
184 /* cpu state */ 181 /* cpu state */
185 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 182 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
183#ifndef NDEBUG
186 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */ 184 JMPENV *idle_te; /* same as idle_sp, but for top_env */
185#endif
187 JMPENV *top_env; 186 JMPENV *top_env;
188 coro_context cctx; 187 coro_context cctx;
189 188
190 U32 gen; 189 U32 gen;
191#if CORO_USE_VALGRIND 190#if CORO_USE_VALGRIND
… …
211}; 210};
212 211
213/* the structure where most of the perl state is stored, overlaid on the cxstack */ 212/* the structure where most of the perl state is stored, overlaid on the cxstack */
214typedef struct 213typedef struct
215{ 214{
216#define VARx(name,expr,type) type name; 215 #define VARx(name,expr,type) type name;
217# include "state.h" 216 #include "state.h"
218#undef VARx
219} perl_slots; 217} perl_slots;
220 218
221/* how many context stack entries do we need for perl_slots */ 219/* how many context stack entries do we need for perl_slots */
222#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT)) 220#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
223 221
… …
641 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); 639 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
642} 640}
643 641
644/** load & save, init *******************************************************/ 642/** load & save, init *******************************************************/
645 643
644ecb_inline void
645swap_sv (SV *a, SV *b)
646{
647 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
648 SV tmp;
649
650 /* swap sv_any */
651 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
652
653 /* swap sv_flags */
654 SvFLAGS (&tmp) = SvFLAGS (a);
655 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
656 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
657
658#if PERL_VERSION_ATLEAST (5,10,0)
659 /* perl 5.10 and later complicates this _quite_ a bit, but it also
660 * is much faster, so no quarrels here. alternatively, we could
661 * sv_upgrade to avoid this.
662 */
663 {
664 /* swap sv_u */
665 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
666
667 /* if SvANY points to the head, we need to adjust the pointers,
668 * as the pointer for a still points to b, and maybe vice versa.
669 */
670 #define svany_in_head(type) \
671 (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
672
673 if (svany_in_head (SvTYPE (a)))
674 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
675
676 if (svany_in_head (SvTYPE (b)))
677 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
678 }
679#endif
680}
681
646/* swap sv heads, at least logically */ 682/* swap sv heads, at least logically */
647static void 683static void
648swap_svs (pTHX_ Coro__State c) 684swap_svs (pTHX_ Coro__State c)
649{ 685{
650 int i; 686 int i;
651 687
652 for (i = 0; i <= AvFILLp (c->swap_sv); ) 688 for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
653 { 689 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
654 SV *a = AvARRAY (c->swap_sv)[i++];
655 SV *b = AvARRAY (c->swap_sv)[i++];
656
657 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
658 SV tmp;
659
660 /* swap sv_any */
661 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
662
663 /* swap sv_flags */
664 SvFLAGS (&tmp) = SvFLAGS (a);
665 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
666 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
667
668#if PERL_VERSION_ATLEAST (5,10,0)
669 /* perl 5.10 complicates this _quite_ a bit, but it also is
670 * much faster, so no quarrels here. alternatively, we could
671 * sv_upgrade to avoid this.
672 */
673 {
674 /* swap sv_u */
675 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
676
677 /* if SvANY points to the head, we need to adjust the pointers,
678 * as the pointer for a still points to b, and maybe vice versa.
679 */
680 #define svany_in_head(type) \
681 (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
682
683 if (svany_in_head (SvTYPE (a)))
684 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
685
686 if (svany_in_head (SvTYPE (b)))
687 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
688 }
689#endif
690 }
691} 690}
692 691
693#define SWAP_SVS(coro) \ 692#define SWAP_SVS(coro) \
694 if (ecb_expect_false ((coro)->swap_sv)) \ 693 if (ecb_expect_false ((coro)->swap_sv)) \
695 swap_svs (aTHX_ (coro)) 694 swap_svs (aTHX_ (coro))
… …
707 706
708#if CORO_JIT 707#if CORO_JIT
709 load_perl_slots (slot); 708 load_perl_slots (slot);
710#else 709#else
711 #define VARx(name,expr,type) expr = slot->name; 710 #define VARx(name,expr,type) expr = slot->name;
712 # include "state.h" 711 #include "state.h"
713 #undef VARx
714#endif 712#endif
715 713
716 { 714 {
717 dSP; 715 dSP;
718 716
… …
840 838
841#if CORO_JIT 839#if CORO_JIT
842 save_perl_slots (slot); 840 save_perl_slots (slot);
843#else 841#else
844 #define VARx(name,expr,type) slot->name = expr; 842 #define VARx(name,expr,type) slot->name = expr;
845 # include "state.h" 843 #include "state.h"
846 #undef VARx
847#endif 844#endif
848 } 845 }
849} 846}
850 847
851/* 848/*
… …
1414transfer_tail (pTHX) 1411transfer_tail (pTHX)
1415{ 1412{
1416 free_coro_mortal (aTHX); 1413 free_coro_mortal (aTHX);
1417} 1414}
1418 1415
1416/* try to exit the same way perl's main function would do */
1417/* we do not bother resetting the environment or other things *7
1418/* that are not, uhm, essential */
1419/* this obviously also doesn't work when perl is embedded */
1420static void ecb_noinline ecb_cold
1421perlish_exit (pTHX)
1422{
1423 int exitstatus = perl_destruct (PL_curinterp);
1424 perl_free (PL_curinterp);
1425 exit (exitstatus);
1426}
1427
1419/* 1428/*
1420 * this is a _very_ stripped down perl interpreter ;) 1429 * this is a _very_ stripped down perl interpreter ;)
1421 */ 1430 */
1422static void 1431static void
1423cctx_run (void *arg) 1432cctx_run (void *arg)
… …
1450 */ 1459 */
1451 1460
1452 /* 1461 /*
1453 * If perl-run returns we assume exit() was being called or the coro 1462 * If perl-run returns we assume exit() was being called or the coro
1454 * fell off the end, which seems to be the only valid (non-bug) 1463 * fell off the end, which seems to be the only valid (non-bug)
1455 * reason for perl_run to return. We try to exit by jumping to the 1464 * reason for perl_run to return. We try to mimic whatever perl is normally
1456 * bootstrap-time "top" top_env, as we cannot restore the "main" 1465 * doing in that case. YMMV.
1457 * coroutine as Coro has no such concept.
1458 * This actually isn't valid with the pthread backend, but OSes requiring
1459 * that backend are too broken to do it in a standards-compliant way.
1460 */ 1466 */
1461 PL_top_env = main_top_env; 1467 perlish_exit (aTHX);
1462 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1463 } 1468 }
1464} 1469}
1465 1470
1466static coro_cctx * 1471static coro_cctx *
1467cctx_new (void) 1472cctx_new (void)
… …
3390 int count; 3395 int count;
3391 3396
3392 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1); 3397 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
3393 3398
3394 PUSHMARK (SP); 3399 PUSHMARK (SP);
3395#define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type)); 3400 #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
3396# include "state.h" 3401 #include "state.h"
3397#undef VARx
3398 count = call_pv ("Coro::State::_jit", G_ARRAY); 3402 count = call_pv ("Coro::State::_jit", G_ARRAY);
3399 SPAGAIN; 3403 SPAGAIN;
3400 3404
3401 save = POPs; save_ptr = SvPVbyte (save, save_len); 3405 save = POPs; save_ptr = SvPVbyte (save, save_len);
3402 load = POPs; load_ptr = SvPVbyte (load, load_len); 3406 load = POPs; load_ptr = SvPVbyte (load, load_len);

Diff Legend

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