--- Coro/Coro/State.xs 2001/10/05 14:20:10 1.36 +++ Coro/Coro/State.xs 2006/01/25 21:43:58 1.71 @@ -1,9 +1,35 @@ +#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 #include #ifdef HAVE_MMAP @@ -18,8 +44,6 @@ # endif #endif -#define MAY_FLUSH /* increases codesize and is rarely used */ - #define SUB_INIT "Coro::State::initialize" #define UCORO_STATE "_coro_state" @@ -34,7 +58,21 @@ #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 (void)0 +# define UNLOCK (void)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 { @@ -49,6 +87,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; @@ -70,6 +111,8 @@ SV **stack_sp; OP *op; SV **curpad; + AV *comppad; + CV *compcv; SV **stack_base; SV **stack_max; SV **tmps_stack; @@ -88,6 +131,7 @@ OP **retstack; I32 retstack_ix; I32 retstack_max; + PMOP *curpm; COP *curcop; JMPENV *top_env; @@ -98,15 +142,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; @@ -135,14 +173,16 @@ av = newAV (); /* will be @_ */ av_extend (av, 0); av_store (newpad, 0, (SV *) av); - AvFLAGS (av) = AVf_REIFY; + AvREIFY_on (av); 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]); @@ -158,8 +198,12 @@ sv = (SV *) newHV (); else sv = NEWSV (0, 0); + +#ifdef SvPADBUSY if (!SvPADBUSY (sv)) +#endif SvPADMY_on (sv); + npad[ix] = sv; } } @@ -198,78 +242,74 @@ return newpadlist; } -#ifdef MAY_FLUSH STATIC void -free_padlist (AV *padlist) +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) @@ -277,7 +317,7 @@ #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) @@ -291,6 +331,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; @@ -306,9 +348,12 @@ PL_savestack = c->savestack; PL_savestack_ix = c->savestack_ix; PL_savestack_max = c->savestack_max; +#ifdef PL_retstack PL_retstack = c->retstack; PL_retstack_ix = c->retstack_ix; PL_retstack_max = c->retstack_max; +#endif + PL_curpm = c->curpm; PL_curcop = c->curcop; PL_top_env = c->top_env; @@ -327,11 +372,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,11 +410,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)) @@ -385,15 +422,17 @@ 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 } if (top_si->si_type == PERLSI_MAIN) @@ -420,6 +459,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; @@ -435,9 +476,12 @@ c->savestack = PL_savestack; c->savestack_ix = PL_savestack_ix; c->savestack_max = PL_savestack_max; +#ifdef PL_retstack c->retstack = PL_retstack; c->retstack_ix = PL_retstack_ix; c->retstack_max = PL_retstack_max; +#endif + c->curpm = PL_curpm; c->curcop = PL_curcop; c->top_env = PL_top_env; } @@ -445,12 +489,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; @@ -469,7 +515,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; @@ -479,14 +527,17 @@ PL_savestack_ix = 0; PL_savestack_max = 96; +#ifdef PL_retstack New(54,PL_retstack,8,OP*); PL_retstack_ix = 0; PL_retstack_max = 8; +#endif + + UNLOCK; } /* * destroy the stacks, the callchain etc... - * still there is a memleak of 128 bytes... */ STATIC void destroy_stacks(pTHX) @@ -494,12 +545,12 @@ if (!IN_DESTRUCT) { /* is this ugly, I ask? */ - while (PL_scopestack_ix) - LEAVE; + LEAVE_SCOPE (0); /* sure it is, but more important: is it correct?? :/ */ - while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */ - FREETMPS; + FREETMPS; + + /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/ } while (PL_curstackinfo->si_next) @@ -509,7 +560,7 @@ { PERL_SI *p = PL_curstackinfo->si_prev; - { + { /*D*//*remove*/ dSP; SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack); PUTBACK; /* possibly superfluous */ @@ -517,20 +568,22 @@ if (!IN_DESTRUCT) { - dounwind(-1); - SvREFCNT_dec(PL_curstackinfo->si_stack); + dounwind (-1);/*D*//*remove*/ + 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); +#ifdef PL_retstack + Safefree (PL_retstack); +#endif } static void @@ -543,17 +596,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 */ +#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 @@ -577,9 +631,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) @@ -593,15 +647,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; @@ -638,7 +693,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 */ @@ -651,14 +706,11 @@ /* * this is a _very_ stripped down perl interpreter ;) */ + dTHX; Coro__State ctx = (Coro__State)arg; JMPENV coro_start_env; - /* same as JMPENV_BOOTSTRAP */ - Zero(&coro_start_env, 1, JMPENV); - coro_start_env.je_ret = -1; - coro_start_env.je_mustcatch = TRUE; - PL_top_env = &coro_start_env; + PL_top_env = &ctx->start_env; ctx->cursp = 0; PL_op = PL_op->op_next; @@ -668,19 +720,18 @@ } STATIC void -transfer(pTHX_ struct coro *prev, struct coro *next, int flags) +transfer (pTHX_ struct coro *prev, struct coro *next, int flags) { dSTACKLEVEL; - static struct coro *xnext; if (prev != next) { - xnext = next; - if (next->mainstack) { + LOCK; SAVE (prev, flags); LOAD (next); + UNLOCK; /* mark this state as in-use */ next->mainstack = 0; @@ -709,15 +760,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 +781,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,56 +793,63 @@ } 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; + } } - - /* - * xnext is now either prev or next, depending on wether - * we switched the c stack or not. that's why i use a global - * variable, that should become thread-specific at one point. - */ - xnext->cursp = stacklevel; } -} -static struct coro * -sv_to_coro (SV *arg, const char *funcname, const char *varname) -{ - if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV) + LOCK; + if (coro_mortal) { - HE *he = hv_fetch_ent((HV *)SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash); - - if (!he) - croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname); - - arg = HeVAL(he); + SvREFCNT_dec (coro_mortal); + coro_mortal = 0; } - - /* must also be changed inside Coro::Cont::yield */ - if (SvROK(arg) && SvOBJECT(SvRV(arg)) - && SvSTASH(SvRV(arg)) == coro_state_stash) - return (struct coro *) SvIV((SV*)SvRV(arg)); - - croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname); - /*NORETURN*/ + 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) { - transfer(aTHX_ - sv_to_coro (prev, "Coro::transfer", "prev"), - sv_to_coro (next, "Coro::transfer", "next"), - flags); + SV_CORO (prev, "Coro::transfer"); + SV_CORO (next, "Coro::transfer"); + + transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags); } /** Coro ********************************************************************/ @@ -802,32 +867,28 @@ static int coro_nready; static void -coro_enq (SV *sv) +coro_enq (pTHX_ SV *sv) { - if (SvROK (sv)) + if (SvTYPE (sv) == SVt_PVHV) { - SV *hv = SvRV (sv); - if (SvTYPE (hv) == SVt_PVHV) - { - SV **xprio = hv_fetch ((HV *)hv, "prio", 4, 0); - int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL; + 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; + prio = prio > PRIO_MAX ? PRIO_MAX + : prio < PRIO_MIN ? PRIO_MIN + : prio; - av_push (coro_ready [prio - PRIO_MIN], sv); - coro_nready++; + av_push (coro_ready [prio - PRIO_MIN], sv); + coro_nready++; - return; - } + return; } croak ("Coro::ready tried to enqueue something that is not a coroutine"); } static SV * -coro_deq (int min_prio) +coro_deq (pTHX_ int min_prio) { int prio = PRIO_MAX - PRIO_MIN; @@ -848,31 +909,55 @@ static void api_ready (SV *coro) { - coro_enq (SvREFCNT_inc (coro)); + dTHX; + + if (SvROK (coro)) + coro = SvRV (coro); + + LOCK; + coro_enq (aTHX_ SvREFCNT_inc (coro)); + UNLOCK; } static void -api_schedule (int cede) +api_schedule (void) { - SV *prev, *next; + dTHX; - prev = GvSV (coro_current); + SV *prev, *next; - if (cede) - coro_enq (SvREFCNT_inc (prev)); + LOCK; - next = coro_deq (PRIO_MIN); + prev = SvRV (GvSV (coro_current)); + next = coro_deq (aTHX_ PRIO_MIN); if (!next) - next = SvREFCNT_inc (GvSV (coro_idle)); + 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; - GvSV (coro_current) = SvREFCNT_inc (next); - transfer (aTHX_ - sv_to_coro (prev, "Coro::schedule", "current coroutine"), - sv_to_coro (next, "Coro::schedule", "next coroutine"), + SV_CORO (next, "Coro::schedule"); + + UNLOCK; + + transfer (aTHX_ SvSTATE (prev), SvSTATE (next), TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK); - SvREFCNT_dec (next); - SvREFCNT_dec (prev); +} + +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 @@ -881,6 +966,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); @@ -890,9 +979,6 @@ 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; @@ -909,11 +995,17 @@ 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: @@ -921,13 +1013,15 @@ void transfer(prev, next, flags) - Coro::State_or_hashref prev - Coro::State_or_hashref next - int 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 @@ -940,41 +1034,28 @@ struct coro temp; PUTBACK; - SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL); - LOAD(aTHX_ coro); + 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 @@ -984,13 +1065,16 @@ 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); @@ -998,13 +1082,12 @@ 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 @@ -1032,6 +1115,7 @@ 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; @@ -1042,6 +1126,8 @@ } } +#if !PERL_MICRO + void ready(self) SV * self @@ -1049,6 +1135,8 @@ CODE: api_ready (self); +#endif + int nready(...) PROTOTYPE: @@ -1060,8 +1148,51 @@ void schedule(...) PROTOTYPE: - ALIAS: - cede = 1 CODE: - api_schedule (ix); + api_schedule (); + +void +cede(...) + PROTOTYPE: + CODE: + api_cede (); + +# and these are hacks +SV * +_aio_get_state () + CODE: +{ + struct { + int errorno; + int laststype; + int laststatval; + Stat_t statcache; + } data; + + data.errorno = errno; + data.laststype = PL_laststype; + data.laststatval = PL_laststatval; + data.statcache = PL_statcache; + RETVAL = newSVpvn ((char *)&data, sizeof data); +} + OUTPUT: + RETVAL + +void +_aio_set_state (char *data_) + PROTOTYPE: $ + CODE: +{ + struct { + int errorno; + int laststype; + int laststatval; + Stat_t statcache; + } *data = (void *)data_; + + errno = data->errorno; + PL_laststype = data->laststype; + PL_laststatval = data->laststatval; + PL_statcache = data->statcache; +}