--- Coro/Coro/State.xs 2001/08/03 12:51:56 1.20 +++ Coro/Coro/State.xs 2005/12/12 20:28:30 1.68 @@ -1,50 +1,78 @@ +#define PERL_NO_GET_CONTEXT + +#include "libcoro/coro.c" + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "libcoro/coro.c" +#include "patchlevel.h" + +#if PERL_VERSION < 6 +# ifndef PL_ppaddr +# define PL_ppaddr ppaddr +# endif +# ifndef call_sv +# define call_sv perl_call_sv +# endif +# ifndef get_sv +# define get_sv perl_get_sv +# endif +# ifndef get_cv +# define get_cv perl_get_cv +# endif +# ifndef IS_PADGV +# define IS_PADGV(v) 0 +# endif +# ifndef IS_PADCONST +# define IS_PADCONST(v) 0 +# endif +#endif #include #ifdef HAVE_MMAP # include # include -# ifndef MAP_ANON -# ifdef MAP_ANONYMOUS -# define MAP_ANON MAP_ANONYMOUS +# ifndef MAP_ANONYMOUS +# ifdef MAP_ANON +# define MAP_ANONYMOUS MAP_ANON # else # undef HAVE_MMAP # endif # endif #endif -#define MAY_FLUSH /* increases codesize */ - -/* perl-related */ -#define TRANSFER_SAVE_DEFAV 0x00000001 -#define TRANSFER_SAVE_DEFSV 0x00000002 -#define TRANSFER_SAVE_ERRSV 0x00000004 -/* c-related */ -#define TRANSFER_SAVE_CCTXT 0x00000008 -#ifdef CORO_LAZY_STACK -# define TRANSFER_LAZY_STACK 0x00000010 -#else -# define TRANSFER_LAZY_STACK 0x00000000 -#endif - -#define TRANSFER_SAVE_ALL (TRANSFER_SAVE_DEFAV|TRANSFER_SAVE_DEFSV \ - |TRANSFER_SAVE_ERRSV|TRANSFER_SAVE_CCTXT) - #define SUB_INIT "Coro::State::initialize" #define UCORO_STATE "_coro_state" -/* The next macro should delcare a variable stacklevel that contains and approximation - * to the current C stack pointer. It's property is that it changes with each call +/* The next macro should declare a variable stacklevel that contains and approximation + * to the current C stack pointer. Its property is that it changes with each call * and should be unique. */ #define dSTACKLEVEL void *stacklevel = &stacklevel +#define IN_DESTRUCT (PL_main_cv == Nullcv) + #define labs(l) ((l) >= 0 ? (l) : -(l)) +#include "CoroAPI.h" + +#ifdef USE_ITHREADS +static perl_mutex coro_mutex; +# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0) +# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0) +#else +# define LOCK 0 +# define UNLOCK 0 +#endif + +static struct CoroAPI coroapi; +static AV *main_mainstack; /* used to differentiate between $main and others */ +static HV *coro_state_stash; +static SV *ucoro_state_sv; +static U32 ucoro_state_hash; +static SV *coro_mortal; /* will be freed after next transfer */ + /* this is actually not only the c stack but also c registers etc... */ typedef struct { int refcnt; /* pointer reference counter */ @@ -58,6 +86,9 @@ } coro_stack; struct coro { + /* the top-level JMPENV for each coroutine, needed to catch dies. */ + JMPENV start_env; + /* the optional C context */ coro_stack *stack; void *cursp; @@ -79,6 +110,8 @@ SV **stack_sp; OP *op; SV **curpad; + AV *comppad; + CV *compcv; SV **stack_base; SV **stack_max; SV **tmps_stack; @@ -97,6 +130,7 @@ OP **retstack; I32 retstack_ix; I32 retstack_max; + PMOP *curpm; COP *curcop; JMPENV *top_env; @@ -107,15 +141,9 @@ typedef struct coro *Coro__State; typedef struct coro *Coro__State_or_hashref; -static AV *main_mainstack; /* used to differentiate between $main and others */ -static HV *coro_state_stash; -static SV *ucoro_state_sv; -static U32 ucoro_state_hash; -static HV *padlist_cache; - /* mostly copied from op.c:cv_clone2 */ STATIC AV * -clone_padlist (AV *protopadlist) +clone_padlist (pTHX_ AV *protopadlist) { AV *av; I32 ix; @@ -149,9 +177,11 @@ for (ix = fpad; ix > 0; ix--) { SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; + if (namesv && namesv != &PL_sv_undef) { char *name = SvPVX (namesv); /* XXX */ + if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') { /* lexical from outside? */ npad[ix] = SvREFCNT_inc (ppad[ix]); @@ -167,8 +197,12 @@ sv = (SV *) newHV (); else sv = NEWSV (0, 0); + +#ifdef SvPADBUSY if (!SvPADBUSY (sv)) +#endif SvPADMY_on (sv); + npad[ix] = sv; } } @@ -207,86 +241,82 @@ return newpadlist; } -#ifdef MAY_FLUSH -STATIC AV * -free_padlist (AV *padlist) +STATIC void +free_padlist (pTHX_ AV *padlist) { /* may be during global destruction */ - if (SvREFCNT(padlist)) + if (SvREFCNT (padlist)) { - I32 i = AvFILLp(padlist); + I32 i = AvFILLp (padlist); while (i >= 0) { - SV **svp = av_fetch(padlist, i--, FALSE); - SV *sv = svp ? *svp : Nullsv; - if (sv) - SvREFCNT_dec(sv); + SV **svp = av_fetch (padlist, i--, FALSE); + if (svp) + { + SV *sv; + while (&PL_sv_undef != (sv = av_pop ((AV *)*svp))) + SvREFCNT_dec (sv); + + SvREFCNT_dec (*svp); + } } - SvREFCNT_dec((SV*)padlist); - } + SvREFCNT_dec ((SV*)padlist); + } } -#endif -/* the next two functions merely cache the padlists */ -STATIC void -get_padlist (CV *cv) +STATIC int +coro_cv_free (pTHX_ SV *sv, MAGIC *mg) { - SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0); + AV *padlist; + AV *av = (AV *)mg->mg_obj; - if (he && AvFILLp ((AV *)*he) >= 0) - CvPADLIST (cv) = (AV *)av_pop ((AV *)*he); - else - CvPADLIST (cv) = clone_padlist (CvPADLIST (cv)); + /* casting is fun. */ + while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) + free_padlist (aTHX_ padlist); + + SvREFCNT_dec (av); } +#define PERL_MAGIC_coro PERL_MAGIC_ext + +static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free}; + +/* the next two functions merely cache the padlists */ STATIC void -put_padlist (CV *cv) +get_padlist (pTHX_ CV *cv) { - SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1); - - if (SvTYPE (*he) != SVt_PVAV) - { - SvREFCNT_dec (*he); - *he = (SV *)newAV (); - } + MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); - av_push ((AV *)*he, (SV *)CvPADLIST (cv)); + if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0) + CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj); + else + CvPADLIST (cv) = clone_padlist (aTHX_ CvPADLIST (cv)); } -#ifdef MAY_FLUSH STATIC void -flush_padlist_cache () +put_padlist (pTHX_ CV *cv) { - HV *hv = padlist_cache; - padlist_cache = newHV (); + MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); - if (hv_iterinit (hv)) + if (!mg) { - HE *he; - AV *padlist; - - while (!!(he = hv_iternext (hv))) - { - AV *av = (AV *)HeVAL(he); - - /* casting is fun. */ - while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) - free_padlist (padlist); - } + sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0); + mg = mg_find ((SV *)cv, PERL_MAGIC_coro); + mg->mg_virtual = &vtbl_coro; + mg->mg_obj = (SV *)newAV (); } - SvREFCNT_dec (hv); + av_push ((AV *)mg->mg_obj, (SV *)CvPADLIST (cv)); } -#endif #define SB do { #define SE } while (0) -#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE -#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE +#define LOAD(state) load_state(aTHX_ (state)); +#define SAVE(state,flags) save_state(aTHX_ (state),(flags)); -#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE +#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE static void load_state(pTHX_ Coro__State c) @@ -300,6 +330,8 @@ PL_stack_sp = c->stack_sp; PL_op = c->op; PL_curpad = c->curpad; + PL_comppad = c->comppad; + PL_compcv = c->compcv; PL_stack_base = c->stack_base; PL_stack_max = c->stack_max; PL_tmps_stack = c->tmps_stack; @@ -318,6 +350,7 @@ PL_retstack = c->retstack; PL_retstack_ix = c->retstack_ix; PL_retstack_max = c->retstack_max; + PL_curpm = c->curpm; PL_curcop = c->curcop; PL_top_env = c->top_env; @@ -336,11 +369,8 @@ if (padlist) { - put_padlist (cv); /* mark this padlist as available */ + put_padlist (aTHX_ cv); /* mark this padlist as available */ CvPADLIST(cv) = padlist; -#ifdef USE_THREADS - /*CvOWNER(cv) = (struct perl_thread *)POPs;*/ -#endif } ++CvDEPTH(cv); @@ -368,7 +398,7 @@ /* this loop was inspired by pp_caller */ for (;;) { - do + while (cxix >= 0) { PERL_CONTEXT *cx = &ccstk[cxix--]; @@ -377,11 +407,6 @@ CV *cv = cx->blk_sub.cv; if (CvDEPTH(cv)) { -#ifdef USE_THREADS - /*XPUSHs ((SV *)CvOWNER(cv));*/ - /*CvOWNER(cv) = 0;*/ - /*error must unlock this cv etc.. etc...*/ -#endif EXTEND (SP, CvDEPTH(cv)*2); while (--CvDEPTH(cv)) @@ -394,17 +419,18 @@ PUSHs ((SV *)CvPADLIST(cv)); PUSHs ((SV *)cv); - get_padlist (cv); /* this is a monster */ + get_padlist (aTHX_ cv); /* this is a monster */ } } +#ifdef CXt_FORMAT else if (CxTYPE(cx) == CXt_FORMAT) { /* I never used formats, so how should I know how these are implemented? */ /* my bold guess is as a simple, plain sub... */ croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); } +#endif } - while (cxix >= 0); if (top_si->si_type == PERLSI_MAIN) break; @@ -421,11 +447,6 @@ c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0; c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0; - /* I have not the slightest idea of why av_reify is necessary */ - /* but if it's missing the defav contents magically get replaced sometimes */ - if (c->defav) - av_reify (c->defav); - c->dowarn = PL_dowarn; c->in_eval = PL_in_eval; @@ -435,6 +456,8 @@ c->stack_sp = PL_stack_sp; c->op = PL_op; c->curpad = PL_curpad; + c->comppad = PL_comppad; + c->compcv = PL_compcv; c->stack_base = PL_stack_base; c->stack_max = PL_stack_max; c->tmps_stack = PL_tmps_stack; @@ -453,6 +476,7 @@ c->retstack = PL_retstack; c->retstack_ix = PL_retstack_ix; c->retstack_max = PL_retstack_max; + c->curpm = PL_curpm; c->curcop = PL_curcop; c->top_env = PL_top_env; } @@ -460,12 +484,14 @@ /* * allocate various perl stacks. This is an exact copy * of perl.c:init_stacks, except that it uses less memory - * on the assumption that coroutines do not usually need - * a lot of stackspace. + * on the (sometimes correct) assumption that coroutines do + * not usually need a lot of stackspace. */ STATIC void coro_init_stacks (pTHX) { + LOCK; + PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1); PL_curstackinfo->si_type = PERLSI_MAIN; PL_curstack = PL_curstackinfo->si_stack; @@ -484,7 +510,9 @@ PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + 16; +#ifdef SET_MARK_OFFSET SET_MARK_OFFSET; +#endif New(54,PL_scopestack,16,I32); PL_scopestack_ix = 0; @@ -497,22 +525,26 @@ New(54,PL_retstack,8,OP*); PL_retstack_ix = 0; PL_retstack_max = 8; + + UNLOCK; } /* * destroy the stacks, the callchain etc... - * still there is a memleak of 128 bytes... */ STATIC void destroy_stacks(pTHX) { - /* is this ugly, I ask? */ - while (PL_scopestack_ix) - LEAVE; - - /* sure it is, but more important: is it correct?? :/ */ - while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */ - FREETMPS; + if (!IN_DESTRUCT) + { + /* is this ugly, I ask? */ + LEAVE_SCOPE (0); + + /* sure it is, but more important: is it correct?? :/ */ + FREETMPS; + + /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/ + } while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; @@ -521,25 +553,28 @@ { PERL_SI *p = PL_curstackinfo->si_prev; - { + { /*D*//*remove*/ dSP; SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack); PUTBACK; /* possibly superfluous */ } - dounwind(-1); + if (!IN_DESTRUCT) + { + dounwind (-1);/*D*//*remove*/ + SvREFCNT_dec (PL_curstackinfo->si_stack); + } - SvREFCNT_dec(PL_curstackinfo->si_stack); - Safefree(PL_curstackinfo->si_cxstack); - Safefree(PL_curstackinfo); + Safefree (PL_curstackinfo->si_cxstack); + Safefree (PL_curstackinfo); PL_curstackinfo = p; } - Safefree(PL_tmps_stack); - Safefree(PL_markstack); - Safefree(PL_scopestack); - Safefree(PL_savestack); - Safefree(PL_retstack); + Safefree (PL_tmps_stack); + Safefree (PL_markstack); + Safefree (PL_scopestack); + Safefree (PL_savestack); + Safefree (PL_retstack); } static void @@ -552,17 +587,18 @@ stack->refcnt = 1; stack->usecnt = 1; stack->gencnt = ctx->gencnt = 0; + if (alloc) { -#ifdef HAVE_MMAP - stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */ - stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0); +#if HAVE_MMAP + stack->ssize = STACKSIZE * sizeof (long); /* mmap should do allocate-on-write for us */ + stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); if (stack->sptr == (void *)-1) #endif { /*FIXME*//*D*//* reasonable stack size! */ - stack->ssize = -4096 * sizeof (long); - New (0, stack->sptr, 4096, long); + stack->ssize = - (STACKSIZE * sizeof (long)); + New (0, stack->sptr, STACKSIZE, long); } } else @@ -586,9 +622,9 @@ if (stack->ssize > 0 && stack->sptr) munmap (stack->sptr, stack->ssize); else -#else - Safefree (stack->sptr); #endif + Safefree (stack->sptr); + Safefree (stack); } else if (ctx->gencnt == stack->gencnt) @@ -602,15 +638,16 @@ /* * emulate part of the perl startup here. */ + dTHX; dSP; Coro__State ctx = (Coro__State)arg; - SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE); + SV *sub_init = (SV *)get_cv (SUB_INIT, FALSE); coro_init_stacks (aTHX); /*PL_curcop = 0;*/ /*PL_in_eval = PL_in_eval;*/ /* inherit */ SvREFCNT_dec (GvAV (PL_defgv)); - GvAV (PL_defgv) = ctx->args; + GvAV (PL_defgv) = ctx->args; ctx->args = 0; SPAGAIN; @@ -647,7 +684,7 @@ * ah yes, and I don't care anyways ;) */ PUTBACK; - PL_op = pp_entersub(); + PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); SPAGAIN; ENTER; /* necessary e.g. for dounwind */ @@ -660,9 +697,12 @@ /* * this is a _very_ stripped down perl interpreter ;) */ + dTHX; Coro__State ctx = (Coro__State)arg; + JMPENV coro_start_env; + + PL_top_env = &ctx->start_env; - /*FIXME*//* must set up top_env here */ ctx->cursp = 0; PL_op = PL_op->op_next; CALLRUNOPS(aTHX); @@ -671,17 +711,18 @@ } STATIC void -transfer(pTHX_ struct coro *prev, struct coro *next, int flags) +transfer (pTHX_ struct coro *prev, struct coro *next, int flags) { - dSP; dSTACKLEVEL; if (prev != next) { if (next->mainstack) { + LOCK; SAVE (prev, flags); LOAD (next); + UNLOCK; /* mark this state as in-use */ next->mainstack = 0; @@ -710,14 +751,19 @@ } coro_transfer (&(prev->stack->cctx), &(next->stack->cctx)); + prev->cursp = stacklevel; + /* don't add any code here */ } - + else + next->cursp = stacklevel; } else if (next->tmps_ix == -2) croak ("tried to transfer to running coroutine"); else { + LOCK; SAVE (prev, -1); /* first get rid of the old state */ + UNLOCK; if (flags & TRANSFER_SAVE_CCTXT) { @@ -726,7 +772,10 @@ if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK) { + PL_top_env = &next->start_env; + setup_coro (next); + next->cursp = stacklevel; prev->stack->refcnt++; prev->stack->usecnt++; @@ -735,19 +784,171 @@ } else { + assert (!next->stack); allocate_stack (next, 1); coro_create (&(next->stack->cctx), setup_coro, (void *)next, next->stack->sptr, labs (next->stack->ssize)); coro_transfer (&(prev->stack->cctx), &(next->stack->cctx)); + prev->cursp = stacklevel; + /* don't add any code here */ } } else - setup_coro (next); + { + setup_coro (next); + next->cursp = stacklevel; + } } } - next->cursp = stacklevel; + LOCK; + if (coro_mortal) + { + SvREFCNT_dec (coro_mortal); + coro_mortal = 0; + } + UNLOCK; +} + +#define SV_CORO(sv,func) \ + do { \ + if (SvROK (sv)) \ + sv = SvRV (sv); \ + \ + if (SvTYPE (sv) == SVt_PVHV) \ + { \ + HE *he = hv_fetch_ent ((HV *)sv, ucoro_state_sv, 0, ucoro_state_hash); \ + \ + if (!he) \ + croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \ + \ + (sv) = SvRV (HeVAL(he)); \ + } \ + \ + /* must also be changed inside Coro::Cont::yield */ \ + if (!SvOBJECT (sv) || SvSTASH (sv) != coro_state_stash) \ + croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \ + \ + } while(0) + +#define SvSTATE(sv) (struct coro *)SvIV (sv) + +static void +api_transfer(pTHX_ SV *prev, SV *next, int flags) +{ + SV_CORO (prev, "Coro::transfer"); + SV_CORO (next, "Coro::transfer"); + + transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags); +} + +/** Coro ********************************************************************/ + +#define PRIO_MAX 3 +#define PRIO_HIGH 1 +#define PRIO_NORMAL 0 +#define PRIO_LOW -1 +#define PRIO_IDLE -3 +#define PRIO_MIN -4 + +/* for Coro.pm */ +static GV *coro_current, *coro_idle; +static AV *coro_ready[PRIO_MAX-PRIO_MIN+1]; +static int coro_nready; + +static void +coro_enq (pTHX_ SV *sv) +{ + if (SvTYPE (sv) == SVt_PVHV) + { + SV **xprio = hv_fetch ((HV *)sv, "prio", 4, 0); + int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL; + + prio = prio > PRIO_MAX ? PRIO_MAX + : prio < PRIO_MIN ? PRIO_MIN + : prio; + + av_push (coro_ready [prio - PRIO_MIN], sv); + coro_nready++; + + return; + } + + croak ("Coro::ready tried to enqueue something that is not a coroutine"); +} + +static SV * +coro_deq (pTHX_ int min_prio) +{ + int prio = PRIO_MAX - PRIO_MIN; + + min_prio -= PRIO_MIN; + if (min_prio < 0) + min_prio = 0; + + for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; ) + if (av_len (coro_ready[prio]) >= 0) + { + coro_nready--; + return av_shift (coro_ready[prio]); + } + + return 0; +} + +static void +api_ready (SV *coro) +{ + dTHX; + + if (SvROK (coro)) + coro = SvRV (coro); + + LOCK; + coro_enq (aTHX_ SvREFCNT_inc (coro)); + UNLOCK; +} + +static void +api_schedule (void) +{ + dTHX; + + SV *prev, *next; + + LOCK; + + prev = SvRV (GvSV (coro_current)); + next = coro_deq (aTHX_ PRIO_MIN); + + if (!next) + next = SvREFCNT_inc (SvRV (GvSV (coro_idle))); + + /* free this only after the transfer */ + coro_mortal = prev; + SV_CORO (prev, "Coro::schedule"); + + SvRV (GvSV (coro_current)) = next; + + SV_CORO (next, "Coro::schedule"); + + UNLOCK; + + transfer (aTHX_ SvSTATE (prev), SvSTATE (next), + TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK); +} + +static void +api_cede (void) +{ + dTHX; + + LOCK; + coro_enq (aTHX_ SvREFCNT_inc (SvRV (GvSV (coro_current)))); + UNLOCK; + + api_schedule (); } MODULE = Coro::State PACKAGE = Coro::State @@ -756,6 +957,10 @@ BOOT: { /* {} necessary for stoopid perl-5.6.x */ +#ifdef USE_ITHREADS + MUTEX_INIT (&coro_mutex); +#endif + ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1); PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1); coro_state_stash = gv_stashpv ("Coro::State", TRUE); @@ -765,10 +970,10 @@ newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV)); newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT)); - if (!padlist_cache) - padlist_cache = newHV (); - main_mainstack = PL_mainstack; + + coroapi.ver = CORO_API_VERSION; + coroapi.transfer = api_transfer; } Coro::State @@ -781,25 +986,33 @@ if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) croak ("Coro::State::_newprocess expects an arrayref"); - New (0, coro, 1, struct coro); + Newz (0, coro, 1, struct coro); coro->args = (AV *)SvREFCNT_inc (SvRV (args)); - coro->mainstack = 0; /* actual work is done inside transfer */ - coro->stack = 0; + /*coro->mainstack = 0; *//*actual work is done inside transfer */ + /*coro->stack = 0;*/ + + /* same as JMPENV_BOOTSTRAP */ + /* we might be able to recycle start_env, but safe is safe */ + /*Zero(&coro->start_env, 1, JMPENV);*/ + coro->start_env.je_ret = -1; + coro->start_env.je_mustcatch = TRUE; RETVAL = coro; OUTPUT: RETVAL void -transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK) - Coro::State_or_hashref prev - Coro::State_or_hashref next - int flags +transfer(prev, next, flags) + SV *prev + SV *next + int flags PROTOTYPE: @ CODE: PUTBACK; - transfer (aTHX_ prev, next, flags); + SV_CORO (next, "Coro::transfer"); + SV_CORO (prev, "Coro::transfer"); + transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags); SPAGAIN; void @@ -811,55 +1024,48 @@ { struct coro temp; - SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL); - LOAD(aTHX_ coro); + PUTBACK; + SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL); + LOAD (aTHX_ coro); + SPAGAIN; destroy_stacks (aTHX); - LOAD((&temp)); /* this will get rid of defsv etc.. */ + LOAD ((&temp)); /* this will get rid of defsv etc.. */ + SPAGAIN; coro->mainstack = 0; } deallocate_stack (coro); - + SvREFCNT_dec (coro->args); Safefree (coro); void -flush() - CODE: -#ifdef MAY_FLUSH - flush_padlist_cache (); -#endif - -void _exit(code) int code PROTOTYPE: $ CODE: -#if defined(__GLIBC__) || _POSIX_C_SOURCE _exit (code); -#else - signal (SIGTERM, SIG_DFL); - raise (SIGTERM); - exit (code); -#endif MODULE = Coro::State PACKAGE = Coro::Cont -# this is slightly dirty +# this is slightly dirty (should expose a c-level api) void yield(...) PROTOTYPE: @ CODE: - static SV *returnstk; + SV *yieldstack; SV *sv; AV *defav = GvAV (PL_defgv); struct coro *prev, *next; - if (!returnstk) - returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE)); + yieldstack = *hv_fetch ( + (HV *)SvRV (GvSV (coro_current)), + "yieldstack", sizeof ("yieldstack") - 1, + 0 + ); /* set up @_ -- ugly */ av_clear (defav); @@ -867,11 +1073,78 @@ while (items--) av_store (defav, items, SvREFCNT_inc (ST(items))); - mg_get (returnstk); /* isn't documentation wrong for mg_get? */ - sv = av_pop ((AV *)SvRV (returnstk)); + sv = av_pop ((AV *)SvRV (yieldstack)); prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0))); next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0))); SvREFCNT_dec (sv); - transfer(aTHX_ prev, next, 0); + transfer (aTHX_ prev, next, 0); + +MODULE = Coro::State PACKAGE = Coro + +# this is slightly dirty (should expose a c-level api) + +BOOT: +{ + int i; + HV *stash = gv_stashpv ("Coro", TRUE); + + newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX)); + newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH)); + newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL)); + newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW)); + newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE)); + newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN)); + + coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV); + coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV); + + for (i = PRIO_MAX - PRIO_MIN + 1; i--; ) + coro_ready[i] = newAV (); + + { + SV *sv = perl_get_sv("Coro::API", 1); + + coroapi.schedule = api_schedule; + coroapi.cede = api_cede; + coroapi.ready = api_ready; + coroapi.nready = &coro_nready; + coroapi.current = coro_current; + + GCoroAPI = &coroapi; + sv_setiv(sv, (IV)&coroapi); + SvREADONLY_on(sv); + } +} + +#if !PERL_MICRO + +void +ready(self) + SV * self + PROTOTYPE: $ + CODE: + api_ready (self); + +#endif + +int +nready(...) + PROTOTYPE: + CODE: + RETVAL = coro_nready; + OUTPUT: + RETVAL + +void +schedule(...) + PROTOTYPE: + CODE: + api_schedule (); + +void +cede(...) + PROTOTYPE: + CODE: + api_cede ();