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.99 by root, Sun Nov 26 23:53:20 2006 UTC vs.
Revision 1.103 by root, Mon Nov 27 01:33:30 2006 UTC

… …
4#include "perl.h" 4#include "perl.h"
5#include "XSUB.h" 5#include "XSUB.h"
6 6
7#include "patchlevel.h" 7#include "patchlevel.h"
8 8
9#if PERL_VERSION < 6 9#define PERL_VERSION_ATLEAST(a,b,c) \
10 (PERL_REVISION > (a) \
11 || (PERL_REVISION == (a) \
12 && (PERL_VERSION > (b) \
13 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
14
15#if !PERL_VERSION_ATLEAST (5,6,0)
10# ifndef PL_ppaddr 16# ifndef PL_ppaddr
11# define PL_ppaddr ppaddr 17# define PL_ppaddr ppaddr
12# endif 18# endif
13# ifndef call_sv 19# ifndef call_sv
14# define call_sv perl_call_sv 20# define call_sv perl_call_sv
… …
63 * and should be unique. */ 69 * and should be unique. */
64#define dSTACKLEVEL int stacklevel 70#define dSTACKLEVEL int stacklevel
65#define STACKLEVEL ((void *)&stacklevel) 71#define STACKLEVEL ((void *)&stacklevel)
66 72
67#define IN_DESTRUCT (PL_main_cv == Nullcv) 73#define IN_DESTRUCT (PL_main_cv == Nullcv)
74
75#if __GNUC__ >= 3
76# define attribute(x) __attribute__(x)
77#else
78# define attribute(x)
79#endif
80
81#define NOINLINE attribute ((noinline))
68 82
69#include "CoroAPI.h" 83#include "CoroAPI.h"
70 84
71#define TRANSFER_SET_STACKLEVEL 0x8bfbfbfb /* magic cookie */ 85#define TRANSFER_SET_STACKLEVEL 0x8bfbfbfb /* magic cookie */
72 86
… …
159 AV *padlist = CvPADLIST (cv); 173 AV *padlist = CvPADLIST (cv);
160 AV *newpadlist, *newpad; 174 AV *newpadlist, *newpad;
161 175
162 newpadlist = newAV (); 176 newpadlist = newAV ();
163 AvREAL_off (newpadlist); 177 AvREAL_off (newpadlist);
164#if PERL_VERSION < 9 178#if PERL_VERSION_ATLEAST (5,9,0)
179 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
180#else
165 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1); 181 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
166#else
167 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
168#endif 182#endif
169 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)]; 183 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
170 --AvFILLp (padlist); 184 --AvFILLp (padlist);
171 185
172 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE))); 186 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
… …
291 PL_scopestack_ix = c->scopestack_ix; 305 PL_scopestack_ix = c->scopestack_ix;
292 PL_scopestack_max = c->scopestack_max; 306 PL_scopestack_max = c->scopestack_max;
293 PL_savestack = c->savestack; 307 PL_savestack = c->savestack;
294 PL_savestack_ix = c->savestack_ix; 308 PL_savestack_ix = c->savestack_ix;
295 PL_savestack_max = c->savestack_max; 309 PL_savestack_max = c->savestack_max;
296#if PERL_VERSION < 9 310#if !PERL_VERSION_ATLEAST (5,9,0)
297 PL_retstack = c->retstack; 311 PL_retstack = c->retstack;
298 PL_retstack_ix = c->retstack_ix; 312 PL_retstack_ix = c->retstack_ix;
299 PL_retstack_max = c->retstack_max; 313 PL_retstack_max = c->retstack_max;
300#endif 314#endif
301 PL_curpm = c->curpm; 315 PL_curpm = c->curpm;
… …
418 c->scopestack_ix = PL_scopestack_ix; 432 c->scopestack_ix = PL_scopestack_ix;
419 c->scopestack_max = PL_scopestack_max; 433 c->scopestack_max = PL_scopestack_max;
420 c->savestack = PL_savestack; 434 c->savestack = PL_savestack;
421 c->savestack_ix = PL_savestack_ix; 435 c->savestack_ix = PL_savestack_ix;
422 c->savestack_max = PL_savestack_max; 436 c->savestack_max = PL_savestack_max;
423#if PERL_VERSION < 9 437#if !PERL_VERSION_ATLEAST (5,9,0)
424 c->retstack = PL_retstack; 438 c->retstack = PL_retstack;
425 c->retstack_ix = PL_retstack_ix; 439 c->retstack_ix = PL_retstack_ix;
426 c->retstack_max = PL_retstack_max; 440 c->retstack_max = PL_retstack_max;
427#endif 441#endif
428 c->curpm = PL_curpm; 442 c->curpm = PL_curpm;
… …
466 480
467 New(54,PL_savestack,96,ANY); 481 New(54,PL_savestack,96,ANY);
468 PL_savestack_ix = 0; 482 PL_savestack_ix = 0;
469 PL_savestack_max = 96; 483 PL_savestack_max = 96;
470 484
471#if PERL_VERSION < 9 485#if !PERL_VERSION_ATLEAST (5,9,0)
472 New(54,PL_retstack,8,OP*); 486 New(54,PL_retstack,8,OP*);
473 PL_retstack_ix = 0; 487 PL_retstack_ix = 0;
474 PL_retstack_max = 8; 488 PL_retstack_max = 8;
475#endif 489#endif
476} 490}
477 491
478/* 492/*
479 * destroy the stacks, the callchain etc... 493 * destroy the stacks, the callchain etc...
480 */ 494 */
481static void 495static void
482destroy_stacks() 496coro_destroy_stacks()
483{ 497{
484 if (!IN_DESTRUCT) 498 if (!IN_DESTRUCT)
485 { 499 {
486 /* is this ugly, I ask? */ 500 /* is this ugly, I ask? */
487 LEAVE_SCOPE (0); 501 LEAVE_SCOPE (0);
… …
518 532
519 Safefree (PL_tmps_stack); 533 Safefree (PL_tmps_stack);
520 Safefree (PL_markstack); 534 Safefree (PL_markstack);
521 Safefree (PL_scopestack); 535 Safefree (PL_scopestack);
522 Safefree (PL_savestack); 536 Safefree (PL_savestack);
523#if PERL_VERSION < 9 537#if !PERL_VERSION_ATLEAST (5,9,0)
524 Safefree (PL_retstack); 538 Safefree (PL_retstack);
525#endif 539#endif
526} 540}
527 541
528static void 542static void
529setup_coro (struct coro *coro) 543setup_coro (struct coro *coro)
530{ 544{
531 /* 545 /*
532 * emulate part of the perl startup here. 546 * emulate part of the perl startup here.
533 */ 547 */
534 dTHX;
535 dSP;
536 UNOP myop;
537 SV *sub_init = (SV *)get_cv ("Coro::State::coro_init", FALSE);
538 548
539 coro_init_stacks (); 549 coro_init_stacks ();
550
540 /*PL_curcop = 0;*/ 551 PL_curcop = 0;
541 /*PL_in_eval = PL_in_eval;*/ /* inherit */ 552 PL_in_eval = 0;
553 PL_curpm = 0;
554
555 {
556 dSP;
557 LOGOP myop;
558
559 /* I have no idea why this is needed, but it is */
560 PUSHMARK (SP);
561
542 SvREFCNT_dec (GvAV (PL_defgv)); 562 SvREFCNT_dec (GvAV (PL_defgv));
543 GvAV (PL_defgv) = coro->args; coro->args = 0; 563 GvAV (PL_defgv) = coro->args; coro->args = 0;
544 564
545 SPAGAIN;
546
547 Zero (&myop, 1, UNOP); 565 Zero (&myop, 1, LOGOP);
548 myop.op_next = Nullop; 566 myop.op_next = Nullop;
549 myop.op_flags = OPf_WANT_VOID; 567 myop.op_flags = OPf_WANT_VOID;
550 568
551 PL_op = (OP *)&myop; 569 PL_op = (OP *)&myop;
552 570
553 PUSHMARK(SP); 571 PUSHMARK (SP);
554 XPUSHs (sub_init); 572 XPUSHs ((SV *)get_cv ("Coro::State::coro_init", FALSE));
555 PUTBACK; 573 PUTBACK;
556 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); 574 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
557 SPAGAIN; 575 SPAGAIN;
558 576
559 ENTER; /* necessary e.g. for dounwind */ 577 ENTER; /* necessary e.g. for dounwind */
578 }
560} 579}
561 580
562static void 581static void
563free_coro_mortal () 582free_coro_mortal ()
564{ 583{
… …
567 SvREFCNT_dec (coro_mortal); 586 SvREFCNT_dec (coro_mortal);
568 coro_mortal = 0; 587 coro_mortal = 0;
569 } 588 }
570} 589}
571 590
572static void 591static void NOINLINE
573prepare_cctx (coro_stack *cctx) 592prepare_cctx (coro_stack *cctx)
574{ 593{
575 dSP; 594 dSP;
576 UNOP myop; 595 LOGOP myop;
577 596
578 Zero (&myop, 1, UNOP); 597 Zero (&myop, 1, LOGOP);
579 myop.op_next = PL_op; 598 myop.op_next = PL_op;
580 myop.op_flags = OPf_WANT_VOID | OPf_STACKED; 599 myop.op_flags = OPf_WANT_VOID;
581 600
601 sv_setiv (get_sv ("Coro::State::cctx_stack", FALSE), PTR2IV (cctx));
602
582 PUSHMARK(SP); 603 PUSHMARK (SP);
583 EXTEND (SP, 2);
584 PUSHs (newSViv (PTR2IV (cctx)));
585 PUSHs ((SV *)get_cv ("Coro::State::cctx_init", FALSE)); 604 XPUSHs ((SV *)get_cv ("Coro::State::cctx_init", FALSE));
586 PUTBACK; 605 PUTBACK;
587 PL_restartop = PL_ppaddr[OP_ENTERSUB](aTHX); 606 PL_restartop = PL_ppaddr[OP_ENTERSUB](aTHX);
588 SPAGAIN; 607 SPAGAIN;
589} 608}
590 609
591static void 610static void
592coro_run (void *arg) 611coro_run (void *arg)
593{ 612{
613 /* coro_run is the alternative epilogue of transfer() */
614 UNLOCK;
615
594 /* 616 /*
595 * this is a _very_ stripped down perl interpreter ;) 617 * this is a _very_ stripped down perl interpreter ;)
596 */ 618 */
597 UNLOCK;
598
599 PL_top_env = &PL_start_env; 619 PL_top_env = &PL_start_env;
620 /* inject call to cctx_init */
600 prepare_cctx ((coro_stack *)arg); 621 prepare_cctx ((coro_stack *)arg);
601 622
602 /* somebody will hit me for both perl_run and PL_restartop */ 623 /* somebody will hit me for both perl_run and PL_restartop */
603 perl_run (PERL_GET_CONTEXT); 624 perl_run (PL_curinterp);
604 625
605 fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr); 626 fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr);
606 abort (); 627 abort ();
607} 628}
608 629
… …
661 682
662 Safefree (stack); 683 Safefree (stack);
663} 684}
664 685
665static coro_stack *stack_first; 686static coro_stack *stack_first;
687static int cctx_count, cctx_idle;
666 688
667static coro_stack * 689static coro_stack *
668stack_get () 690stack_get ()
669{ 691{
670 coro_stack *stack; 692 coro_stack *stack;
671 693
672 if (stack_first) 694 if (stack_first)
673 { 695 {
696 --cctx_idle;
674 stack = stack_first; 697 stack = stack_first;
675 stack_first = stack->next; 698 stack_first = stack->next;
676 } 699 }
677 else 700 else
678 { 701 {
702 ++cctx_count;
679 stack = stack_new (); 703 stack = stack_new ();
680 PL_op = PL_op->op_next; 704 PL_op = PL_op->op_next;
681 } 705 }
682 706
683 return stack; 707 return stack;
684} 708}
685 709
686static void 710static void
687stack_put (coro_stack *stack) 711stack_put (coro_stack *stack)
688{ 712{
713 ++cctx_idle;
689 stack->next = stack_first; 714 stack->next = stack_first;
690 stack_first = stack; 715 stack_first = stack;
691} 716}
692 717
693/* never call directly, always through the coro_state_transfer global variable */ 718/* never call directly, always through the coro_state_transfer global variable */
694static void 719static void NOINLINE
695transfer_impl (struct coro *prev, struct coro *next, int flags) 720transfer (struct coro *prev, struct coro *next, int flags)
696{ 721{
697 dSTACKLEVEL; 722 dSTACKLEVEL;
698 723
699 /* sometimes transfer is only called to set idle_sp */ 724 /* sometimes transfer is only called to set idle_sp */
700 if (flags == TRANSFER_SET_STACKLEVEL) 725 if (flags == TRANSFER_SET_STACKLEVEL)
… …
749 774
750 UNLOCK; 775 UNLOCK;
751 } 776 }
752} 777}
753 778
754/* use this function pointer to call the above function */
755/* this is done to increase chances of the compiler not inlining the call */
756/* not static to make it even harder for the compiler (and theoretically impossible in most cases */
757void (*coro_state_transfer)(struct coro *prev, struct coro *next, int flags) = transfer_impl;
758
759struct transfer_args 779struct transfer_args
760{ 780{
761 struct coro *prev, *next; 781 struct coro *prev, *next;
762 int flags; 782 int flags;
763}; 783};
764 784
765#define TRANSFER(ta) coro_state_transfer ((ta).prev, (ta).next, (ta).flags) 785#define TRANSFER(ta) transfer ((ta).prev, (ta).next, (ta).flags)
766 786
767static void 787static void
768coro_state_destroy (struct coro *coro) 788coro_state_destroy (struct coro *coro)
769{ 789{
770 if (coro->refcnt--) 790 if (coro->refcnt--)
… …
775 struct coro temp; 795 struct coro temp;
776 796
777 SAVE ((&temp), TRANSFER_SAVE_ALL); 797 SAVE ((&temp), TRANSFER_SAVE_ALL);
778 LOAD (coro); 798 LOAD (coro);
779 799
780 destroy_stacks (); 800 coro_destroy_stacks ();
781 801
782 LOAD ((&temp)); /* this will get rid of defsv etc.. */ 802 LOAD ((&temp)); /* this will get rid of defsv etc.. */
783 803
784 coro->mainstack = 0; 804 coro->mainstack = 0;
785 } 805 }
… …
808 ++coro->refcnt; 828 ++coro->refcnt;
809 829
810 return 0; 830 return 0;
811} 831}
812 832
813static MGVTBL coro_state_vtbl = { 0, 0, 0, 0, coro_state_clear, 0, coro_state_dup, 0 }; 833static MGVTBL coro_state_vtbl = {
834 0, 0, 0, 0,
835 coro_state_clear,
836 0,
837#ifdef MGf_DUP
838 coro_state_dup,
839#else
840# define MGf_DUP 0
841#endif
842};
814 843
815static struct coro * 844static struct coro *
816SvSTATE (SV *coro) 845SvSTATE (SV *coro)
817{ 846{
818 HV *stash; 847 HV *stash;
… …
1112 ++coro_src->refcnt; 1141 ++coro_src->refcnt;
1113 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP; 1142 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1114} 1143}
1115 1144
1116void 1145void
1117_nonlocal_goto (IV nextop)
1118 CODE:
1119 /* uuh, somebody will kill me again for this */
1120 PL_op->op_next = INT2PTR (OP *, nextop);
1121
1122void
1123_exit (code) 1146_exit (code)
1124 int code 1147 int code
1125 PROTOTYPE: $ 1148 PROTOTYPE: $
1126 CODE: 1149 CODE:
1127 _exit (code); 1150 _exit (code);

Diff Legend

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