… | |
… | |
181 | void *sptr; |
181 | void *sptr; |
182 | size_t ssize; |
182 | size_t ssize; |
183 | |
183 | |
184 | /* cpu state */ |
184 | /* cpu state */ |
185 | 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 |
186 | 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 |
187 | JMPENV *top_env; |
189 | JMPENV *top_env; |
188 | coro_context cctx; |
190 | coro_context cctx; |
189 | |
191 | |
190 | U32 gen; |
192 | U32 gen; |
191 | #if CORO_USE_VALGRIND |
193 | #if CORO_USE_VALGRIND |
… | |
… | |
641 | AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); |
643 | AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); |
642 | } |
644 | } |
643 | |
645 | |
644 | /** load & save, init *******************************************************/ |
646 | /** load & save, init *******************************************************/ |
645 | |
647 | |
|
|
648 | ecb_inline void |
|
|
649 | swap_sv (SV *a, SV *b) |
|
|
650 | { |
|
|
651 | const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */ |
|
|
652 | SV tmp; |
|
|
653 | |
|
|
654 | /* swap sv_any */ |
|
|
655 | SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp); |
|
|
656 | |
|
|
657 | /* swap sv_flags */ |
|
|
658 | SvFLAGS (&tmp) = SvFLAGS (a); |
|
|
659 | SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep); |
|
|
660 | SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep); |
|
|
661 | |
|
|
662 | #if PERL_VERSION_ATLEAST (5,10,0) |
|
|
663 | /* perl 5.10 and later complicates this _quite_ a bit, but it also |
|
|
664 | * is much faster, so no quarrels here. alternatively, we could |
|
|
665 | * sv_upgrade to avoid this. |
|
|
666 | */ |
|
|
667 | { |
|
|
668 | /* swap sv_u */ |
|
|
669 | tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u; |
|
|
670 | |
|
|
671 | /* if SvANY points to the head, we need to adjust the pointers, |
|
|
672 | * as the pointer for a still points to b, and maybe vice versa. |
|
|
673 | */ |
|
|
674 | #define svany_in_head(type) \ |
|
|
675 | (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type))) |
|
|
676 | |
|
|
677 | if (svany_in_head (SvTYPE (a))) |
|
|
678 | SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a); |
|
|
679 | |
|
|
680 | if (svany_in_head (SvTYPE (b))) |
|
|
681 | SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b); |
|
|
682 | } |
|
|
683 | #endif |
|
|
684 | } |
|
|
685 | |
646 | /* swap sv heads, at least logically */ |
686 | /* swap sv heads, at least logically */ |
647 | static void |
687 | static void |
648 | swap_svs (pTHX_ Coro__State c) |
688 | swap_svs (pTHX_ Coro__State c) |
649 | { |
689 | { |
650 | int i; |
690 | int i; |
651 | |
691 | |
652 | for (i = 0; i <= AvFILLp (c->swap_sv); ) |
692 | for (i = 0; i <= AvFILLp (c->swap_sv); i += 2) |
653 | { |
693 | 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 | } |
694 | } |
692 | |
695 | |
693 | #define SWAP_SVS(coro) \ |
696 | #define SWAP_SVS(coro) \ |
694 | if (ecb_expect_false ((coro)->swap_sv)) \ |
697 | if (ecb_expect_false ((coro)->swap_sv)) \ |
695 | swap_svs (aTHX_ (coro)) |
698 | swap_svs (aTHX_ (coro)) |
… | |
… | |
998 | if (strEQ (s, "__DIE__" )) svp = &PL_diehook; |
1001 | if (strEQ (s, "__DIE__" )) svp = &PL_diehook; |
999 | if (strEQ (s, "__WARN__")) svp = &PL_warnhook; |
1002 | if (strEQ (s, "__WARN__")) svp = &PL_warnhook; |
1000 | |
1003 | |
1001 | if (svp) |
1004 | if (svp) |
1002 | { |
1005 | { |
1003 | sv_setsv (sv, *svp ? *svp : &PL_sv_undef); |
1006 | SV *ssv; |
|
|
1007 | |
|
|
1008 | if (!*svp) |
|
|
1009 | ssv = &PL_sv_undef; |
|
|
1010 | else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */ |
|
|
1011 | ssv = sv_2mortal (newRV_inc (*svp)); |
|
|
1012 | else |
|
|
1013 | ssv = *svp; |
|
|
1014 | |
|
|
1015 | sv_setsv (sv, ssv); |
1004 | return 0; |
1016 | return 0; |
1005 | } |
1017 | } |
1006 | } |
1018 | } |
1007 | |
1019 | |
1008 | return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0; |
1020 | return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0; |
… | |
… | |
1398 | |
1410 | |
1399 | slf_frame.prepare = slf_prepare_set_stacklevel; |
1411 | slf_frame.prepare = slf_prepare_set_stacklevel; |
1400 | slf_frame.check = slf_check_set_stacklevel; |
1412 | slf_frame.check = slf_check_set_stacklevel; |
1401 | } |
1413 | } |
1402 | |
1414 | |
|
|
1415 | /* try to exit the same way perl's main function would do */ |
|
|
1416 | /* we do not bother resetting the environment or other things *7 |
|
|
1417 | /* that are not, uhm, essential */ |
|
|
1418 | /* this obviously also doesn't work when perl is embedded */ |
|
|
1419 | static void ecb_noinline ecb_cold |
|
|
1420 | perlish_exit (void) |
|
|
1421 | { |
|
|
1422 | int exitstatus = perl_destruct (PL_curinterp); |
|
|
1423 | perl_free (PL_curinterp); |
|
|
1424 | exit (exitstatus); |
|
|
1425 | } |
|
|
1426 | |
1403 | /* the tail of transfer: execute stuff we can only do after a transfer */ |
1427 | /* the tail of transfer: execute stuff we can only do after a transfer */ |
1404 | ecb_inline void |
1428 | ecb_inline void |
1405 | transfer_tail (pTHX) |
1429 | transfer_tail (pTHX) |
1406 | { |
1430 | { |
1407 | free_coro_mortal (aTHX); |
1431 | free_coro_mortal (aTHX); |
… | |
… | |
1441 | */ |
1465 | */ |
1442 | |
1466 | |
1443 | /* |
1467 | /* |
1444 | * If perl-run returns we assume exit() was being called or the coro |
1468 | * If perl-run returns we assume exit() was being called or the coro |
1445 | * fell off the end, which seems to be the only valid (non-bug) |
1469 | * fell off the end, which seems to be the only valid (non-bug) |
1446 | * reason for perl_run to return. We try to exit by jumping to the |
1470 | * reason for perl_run to return. We try to mimic whatever perl is normally |
1447 | * bootstrap-time "top" top_env, as we cannot restore the "main" |
1471 | * doing in that case. YMMV. |
1448 | * coroutine as Coro has no such concept. |
|
|
1449 | * This actually isn't valid with the pthread backend, but OSes requiring |
|
|
1450 | * that backend are too broken to do it in a standards-compliant way. |
|
|
1451 | */ |
1472 | */ |
1452 | PL_top_env = main_top_env; |
1473 | perlish_exit (); |
1453 | JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */ |
|
|
1454 | } |
1474 | } |
1455 | } |
1475 | } |
1456 | |
1476 | |
1457 | static coro_cctx * |
1477 | static coro_cctx * |
1458 | cctx_new (void) |
1478 | cctx_new (void) |