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.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.15 by root, Wed Jul 25 04:14:38 2001 UTC

1#include "EXTERN.h" 1#include "EXTERN.h"
2#include "perl.h" 2#include "perl.h"
3#include "XSUB.h" 3#include "XSUB.h"
4 4
5#if 0 5#include "libcoro/coro.c"
6# define CHK(x) (void *)0 6
7#ifdef HAVE_MMAP
8# include <unistd.h>
9# include <sys/mman.h>
10#endif
11
12#define MAY_FLUSH /* increases codesize */
13
14/* perl-related */
15#define TRANSFER_SAVE_DEFAV 0x00000001
16#define TRANSFER_SAVE_DEFSV 0x00000002
17#define TRANSFER_SAVE_ERRSV 0x00000004
18/* c-related */
19#define TRANSFER_SAVE_CCTXT 0x00000008
20#ifdef CORO_LAZY_STACK
21# define TRANSFER_LAZY_STACK 0x00000010
7#else 22#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 23# define TRANSFER_LAZY_STACK 0x00000000
9#endif 24#endif
25
26#define TRANSFER_SAVE_ALL (TRANSFER_SAVE_DEFAV|TRANSFER_SAVE_DEFSV \
27 |TRANSFER_SAVE_ERRSV|TRANSFER_SAVE_CCTXT)
28
29#define SUB_INIT "Coro::State::initialize"
30#define UCORO_STATE "_coro_state"
31
32/* The next macro should delcare a variable stacklevel that contains and approximation
33 * to the current C stack pointer. It's property is that it changes with each call
34 * and should be unique. */
35#define dSTACKLEVEL void *stacklevel = &stacklevel
36
37#define labs(l) ((l) >= 0 ? (l) : -(l))
38
39/* this is actually not only the c stack but also c registers etc... */
40typedef struct {
41 int refcnt; /* pointer reference counter */
42 int usecnt; /* shared by how many coroutines */
43 int gencnt; /* generation counter */
44
45 coro_context cctx;
46
47 void *sptr;
48 long ssize; /* positive == mmap, otherwise malloc */
49} coro_stack;
50
51static coro_stack main_stack = { 1, 0, 0 };
10 52
11struct coro { 53struct coro {
54 /* the optional C context */
55 coro_stack *stack;
56 void *cursp;
57 int gencnt;
58
59 /* optionally saved, might be zero */
60 AV *defav;
61 SV *defsv;
62 SV *errsv;
63
64 /* saved global state not related to stacks */
12 U8 dowarn; 65 U8 dowarn;
13 AV *defav; 66
14 67 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 68 PERL_SI *curstackinfo;
16 AV *curstack; 69 AV *curstack;
17 AV *mainstack; 70 AV *mainstack;
18 SV **stack_sp; 71 SV **stack_sp;
19 OP *op; 72 OP *op;
… …
35 I32 savestack_max; 88 I32 savestack_max;
36 OP **retstack; 89 OP **retstack;
37 I32 retstack_ix; 90 I32 retstack_ix;
38 I32 retstack_max; 91 I32 retstack_max;
39 COP *curcop; 92 COP *curcop;
93 JMPENV start_env;
94 JMPENV *top_env;
40 95
96 /* data associated with this coroutine (initial args) */
41 AV *args; 97 AV *args;
42}; 98};
43 99
44typedef struct coro *Coro__State; 100typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 101typedef struct coro *Coro__State_or_hashref;
46 102
103static AV *main_mainstack; /* used to differentiate between $main and others */
104static HV *coro_state_stash;
105static SV *ucoro_state_sv;
106static U32 ucoro_state_hash;
47static HV *padlist_cache; 107static HV *padlist_cache;
48 108
49/* mostly copied from op.c:cv_clone2 */ 109/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 110STATIC AV *
51clone_padlist (AV *protopadlist) 111clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 175 SvPADTMP_on (sv);
116 npad[ix] = sv; 176 npad[ix] = sv;
117 } 177 }
118 } 178 }
119 179
120#if 0 /* NONOTUNDERSTOOD */ 180#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 181 /* Now that vars are all in place, clone nested closures. */
122 182
123 for (ix = fpad; ix > 0; ix--) { 183 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 184 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 185 if (namesv
… …
138#endif 198#endif
139 199
140 return newpadlist; 200 return newpadlist;
141} 201}
142 202
203#ifdef MAY_FLUSH
143STATIC AV * 204STATIC AV *
144free_padlist (AV *padlist) 205free_padlist (AV *padlist)
145{ 206{
146 /* may be during global destruction */ 207 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 208 if (SvREFCNT(padlist))
… …
156 } 217 }
157 218
158 SvREFCNT_dec((SV*)padlist); 219 SvREFCNT_dec((SV*)padlist);
159 } 220 }
160} 221}
222#endif
161 223
162STATIC AV * 224/* the next two functions merely cache the padlists */
163unuse_padlist (AV *padlist) 225STATIC void
226get_padlist (CV *cv)
164{ 227{
228 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
229
230 if (he && AvFILLp ((AV *)*he) >= 0)
231 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
232 else
233 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
234}
235
236STATIC void
237put_padlist (CV *cv)
238{
239 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
240
241 if (SvTYPE (*he) != SVt_PVAV)
242 {
243 SvREFCNT_dec (*he);
244 *he = (SV *)newAV ();
245 }
246
247 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
248}
249
250#ifdef MAY_FLUSH
251STATIC void
252flush_padlist_cache ()
253{
254 HV *hv = padlist_cache;
255 padlist_cache = newHV ();
256
257 if (hv_iterinit (hv))
258 {
259 HE *he;
260 AV *padlist;
261
262 while (!!(he = hv_iternext (hv)))
263 {
264 AV *av = (AV *)HeVAL(he);
265
266 /* casting is fun. */
267 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
165 free_padlist (padlist); 268 free_padlist (padlist);
269 }
270 }
271
272 SvREFCNT_dec (hv);
166} 273}
274#endif
275
276#define SB do {
277#define SE } while (0)
278
279#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
280#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
281
282#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
167 283
168static void 284static void
169SAVE(pTHX_ Coro__State c) 285load_state(pTHX_ Coro__State c)
286{
287 PL_dowarn = c->dowarn;
288
289 PL_curstackinfo = c->curstackinfo;
290 PL_curstack = c->curstack;
291 PL_mainstack = c->mainstack;
292 PL_stack_sp = c->stack_sp;
293 PL_op = c->op;
294 PL_curpad = c->curpad;
295 PL_stack_base = c->stack_base;
296 PL_stack_max = c->stack_max;
297 PL_tmps_stack = c->tmps_stack;
298 PL_tmps_floor = c->tmps_floor;
299 PL_tmps_ix = c->tmps_ix;
300 PL_tmps_max = c->tmps_max;
301 PL_markstack = c->markstack;
302 PL_markstack_ptr = c->markstack_ptr;
303 PL_markstack_max = c->markstack_max;
304 PL_scopestack = c->scopestack;
305 PL_scopestack_ix = c->scopestack_ix;
306 PL_scopestack_max = c->scopestack_max;
307 PL_savestack = c->savestack;
308 PL_savestack_ix = c->savestack_ix;
309 PL_savestack_max = c->savestack_max;
310 PL_retstack = c->retstack;
311 PL_retstack_ix = c->retstack_ix;
312 PL_retstack_max = c->retstack_max;
313 PL_curcop = c->curcop;
314 PL_start_env = c->start_env;
315 PL_top_env = c->top_env;
316
317 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
318 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
319 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
320
321 {
322 dSP;
323 CV *cv;
324
325 /* now do the ugly restore mess */
326 while ((cv = (CV *)POPs))
327 {
328 AV *padlist = (AV *)POPs;
329
330 if (padlist)
331 {
332 put_padlist (cv); /* mark this padlist as available */
333 CvPADLIST(cv) = padlist;
334#ifdef USE_THREADS
335 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
336#endif
337 }
338
339 ++CvDEPTH(cv);
340 }
341
342 PUTBACK;
343 }
344}
345
346static void
347save_state(pTHX_ Coro__State c, int flags)
170{ 348{
171 { 349 {
172 dSP; 350 dSP;
173 I32 cxix = cxstack_ix; 351 I32 cxix = cxstack_ix;
352 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 353 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 354
177 /* 355 /*
178 * the worst thing you can imagine happens first - we have to save 356 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 357 * (and reinitialize) all cv's in the whole callchain :(
180 */ 358 */
181 359
182 PUSHs (Nullsv); 360 PUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 361 /* this loop was inspired by pp_caller */
184 for (;;) 362 for (;;)
185 { 363 {
186 while (cxix >= 0) 364 do
187 { 365 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 366 PERL_CONTEXT *cx = &ccstk[cxix--];
189 367
190 if (CxTYPE(cx) == CXt_SUB) 368 if (CxTYPE(cx) == CXt_SUB)
191 { 369 {
192 CV *cv = cx->blk_sub.cv; 370 CV *cv = cx->blk_sub.cv;
193 if (CvDEPTH(cv)) 371 if (CvDEPTH(cv))
194 { 372 {
195#ifdef USE_THREADS 373#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv)); 374 /*XPUSHs ((SV *)CvOWNER(cv));*/
375 /*CvOWNER(cv) = 0;*/
376 /*error must unlock this cv etc.. etc...*/
197#endif 377#endif
198 EXTEND (SP, 3); 378 EXTEND (SP, CvDEPTH(cv)*2);
379
380 while (--CvDEPTH(cv))
381 {
382 /* this tells the restore code to increment CvDEPTH */
383 PUSHs (Nullsv);
199 PUSHs ((SV *)CvDEPTH(cv)); 384 PUSHs ((SV *)cv);
385 }
386
200 PUSHs ((SV *)CvPADLIST(cv)); 387 PUSHs ((SV *)CvPADLIST(cv));
201 PUSHs ((SV *)cv); 388 PUSHs ((SV *)cv);
202 389
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv)); 390 get_padlist (cv); /* this is a monster */
204
205 CvDEPTH(cv) = 0;
206#ifdef USE_THREADS
207 CvOWNER(cv) = 0;
208 error must unlock this cv etc.. etc...
209 if you are here wondering about this error message then
210 the reason is that it will not work as advertised yet
211#endif
212 } 391 }
213 } 392 }
214 else if (CxTYPE(cx) == CXt_FORMAT) 393 else if (CxTYPE(cx) == CXt_FORMAT)
215 { 394 {
216 /* I never used formats, so how should I know how these are implemented? */ 395 /* I never used formats, so how should I know how these are implemented? */
217 /* my bold guess is as a simple, plain sub... */ 396 /* my bold guess is as a simple, plain sub... */
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 397 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219 } 398 }
220 } 399 }
400 while (cxix >= 0);
221 401
222 if (top_si->si_type == PERLSI_MAIN) 402 if (top_si->si_type == PERLSI_MAIN)
223 break; 403 break;
224 404
225 top_si = top_si->si_prev; 405 top_si = top_si->si_prev;
… …
228 } 408 }
229 409
230 PUTBACK; 410 PUTBACK;
231 } 411 }
232 412
413 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
414 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
415 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
416
417 /* I have not the slightest idea of why av_reify is necessary */
418 /* but if it's missing the defav contents magically get replaced sometimes */
419 if (c->defav)
420 av_reify (c->defav);
421
233 c->dowarn = PL_dowarn; 422 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 423
235 c->curstackinfo = PL_curstackinfo; 424 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack; 425 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack; 426 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp; 427 c->stack_sp = PL_stack_sp;
239 c->op = PL_op; 428 c->op = PL_op;
… …
255 c->savestack_max = PL_savestack_max; 444 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack; 445 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix; 446 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max; 447 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop; 448 c->curcop = PL_curcop;
449 c->start_env = PL_start_env;
450 c->top_env = PL_top_env;
451}
452
453/*
454 * allocate various perl stacks. This is an exact copy
455 * of perl.c:init_stacks, except that it uses less memory
456 * on the assumption that coroutines do not usually need
457 * a lot of stackspace.
458 */
459STATIC void
460coro_init_stacks (pTHX)
461{
462 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
463 PL_curstackinfo->si_type = PERLSI_MAIN;
464 PL_curstack = PL_curstackinfo->si_stack;
465 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
466
467 PL_stack_base = AvARRAY(PL_curstack);
468 PL_stack_sp = PL_stack_base;
469 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
470
471 New(50,PL_tmps_stack,96,SV*);
472 PL_tmps_floor = -1;
473 PL_tmps_ix = -1;
474 PL_tmps_max = 96;
475
476 New(54,PL_markstack,16,I32);
477 PL_markstack_ptr = PL_markstack;
478 PL_markstack_max = PL_markstack + 16;
479
480 SET_MARK_OFFSET;
481
482 New(54,PL_scopestack,16,I32);
483 PL_scopestack_ix = 0;
484 PL_scopestack_max = 16;
485
486 New(54,PL_savestack,96,ANY);
487 PL_savestack_ix = 0;
488 PL_savestack_max = 96;
489
490 New(54,PL_retstack,8,OP*);
491 PL_retstack_ix = 0;
492 PL_retstack_max = 8;
493}
494
495/*
496 * destroy the stacks, the callchain etc...
497 * still there is a memleak of 128 bytes...
498 */
499STATIC void
500destroy_stacks(pTHX)
501{
502 /* is this ugly, I ask? */
503 while (PL_scopestack_ix)
504 LEAVE;
505
506 /* sure it is, but more important: is it correct?? :/ */
507 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
508 FREETMPS;
509
510 while (PL_curstackinfo->si_next)
511 PL_curstackinfo = PL_curstackinfo->si_next;
512
513 while (PL_curstackinfo)
514 {
515 PERL_SI *p = PL_curstackinfo->si_prev;
516
517 {
518 dSP;
519 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
520 PUTBACK; /* possibly superfluous */
521 }
522
523 dounwind(-1);
524
525 SvREFCNT_dec(PL_curstackinfo->si_stack);
526 Safefree(PL_curstackinfo->si_cxstack);
527 Safefree(PL_curstackinfo);
528 PL_curstackinfo = p;
529 }
530
531 Safefree(PL_tmps_stack);
532 Safefree(PL_markstack);
533 Safefree(PL_scopestack);
534 Safefree(PL_savestack);
535 Safefree(PL_retstack);
260} 536}
261 537
262static void 538static void
263LOAD(pTHX_ Coro__State c) 539allocate_stack (Coro__State ctx, int alloc)
264{ 540{
265 PL_dowarn = c->dowarn; 541 coro_stack *stack;
266 GvAV (PL_defgv) = c->defav;
267 PL_curstackinfo = c->curstackinfo;
268 PL_curstack = c->curstack;
269 PL_mainstack = c->mainstack;
270 PL_stack_sp = c->stack_sp;
271 PL_op = c->op;
272 PL_curpad = c->curpad;
273 PL_stack_base = c->stack_base;
274 PL_stack_max = c->stack_max;
275 PL_tmps_stack = c->tmps_stack;
276 PL_tmps_floor = c->tmps_floor;
277 PL_tmps_ix = c->tmps_ix;
278 PL_tmps_max = c->tmps_max;
279 PL_markstack = c->markstack;
280 PL_markstack_ptr = c->markstack_ptr;
281 PL_markstack_max = c->markstack_max;
282 PL_scopestack = c->scopestack;
283 PL_scopestack_ix = c->scopestack_ix;
284 PL_scopestack_max = c->scopestack_max;
285 PL_savestack = c->savestack;
286 PL_savestack_ix = c->savestack_ix;
287 PL_savestack_max = c->savestack_max;
288 PL_retstack = c->retstack;
289 PL_retstack_ix = c->retstack_ix;
290 PL_retstack_max = c->retstack_max;
291 PL_curcop = c->curcop;
292 542
543 New (0, stack, 1, coro_stack);
544
545 stack->refcnt = 1;
546 stack->usecnt = 1;
547 stack->gencnt = ctx->gencnt = 0;
548 if (alloc)
293 { 549 {
294 dSP; 550#ifdef HAVE_MMAP
295 CV *cv; 551 stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
296 552 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
297 /* now do the ugly restore mess */ 553 if (stack->sptr == (void *)-1)
298 while ((cv = (CV *)POPs)) 554#endif
299 { 555 {
300 AV *padlist = (AV *)POPs; 556 /*FIXME*//*D*//* reasonable stack size! */
301 557 stack->ssize = -4096 * sizeof (long);
302 unuse_padlist (CvPADLIST(cv)); 558 New (0, stack->sptr, 4096, long);
303 CvPADLIST(cv) = padlist;
304 CvDEPTH(cv) = (I32)POPs;
305
306#ifdef USE_THREADS
307 CvOWNER(cv) = (struct perl_thread *)POPs;
308 error does not work either
309#endif
310 } 559 }
560 }
561 else
562 stack->sptr = 0;
311 563
564 ctx->stack = stack;
565}
566
567static void
568deallocate_stack (Coro__State ctx)
569{
570 coro_stack *stack = ctx->stack;
571
572 ctx->stack = 0;
573
574 if (stack)
575 {
576 if (!--stack->refcnt)
577 {
578#ifdef HAVE_MMAP
579 if (stack->ssize > 0 && stack->sptr)
580 munmap (stack->sptr, stack->ssize);
581 else
582#else
583 Safefree (stack->sptr);
584#endif
585 Safefree (stack);
586 }
587 else if (ctx->gencnt == stack->gencnt)
588 --stack->usecnt;
589 }
590}
591
592static void
593setup_coro (void *arg)
594{
595 /*
596 * emulate part of the perl startup here.
597 */
598 dSP;
599 Coro__State ctx = (Coro__State)arg;
600 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
601
602 coro_init_stacks (aTHX);
603 JMPENV_BOOTSTRAP;
604 SPAGAIN;
605
606 /*PL_curcop = 0;*/
607 SvREFCNT_dec (GvAV (PL_defgv));
608 GvAV (PL_defgv) = ctx->args;
609
610 if (ctx->stack)
611 {
612 ctx->cursp = 0;
613
614 PUSHMARK(SP);
312 PUTBACK; 615 PUTBACK;
616 (void) call_sv (sub_init, G_VOID|G_NOARGS);
617 croak ("FATAL: CCTXT coroutine returned!");
313 } 618 }
314} 619 else
620 {
621 UNOP myop;
315 622
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 623 PL_op = (OP *)&myop;
624
625 Zero(&myop, 1, UNOP);
626 myop.op_next = Nullop;
627 myop.op_flags = OPf_WANT_VOID;
628
629 PUSHMARK(SP);
630 XPUSHs (sub_init);
631 /*
632 * the next line is slightly wrong, as PL_op->op_next
633 * is actually being executed so we skip the first op.
634 * that doesn't matter, though, since it is only
635 * pp_nextstate and we never return...
636 * ah yes, and I don't care anyways ;)
637 */
638 PUTBACK;
639 PL_op = pp_entersub();
640 SPAGAIN;
641
642 ENTER; /* necessary e.g. for dounwind */
643 }
644}
645
646static void
647continue_coro (void *arg)
648{
649 /*
650 * this is a _very_ stripped down perl interpreter ;)
651 */
652 Coro__State ctx = (Coro__State)arg;
653
654 ctx->cursp = 0;
655 PL_op = PL_op->op_next;
656 CALLRUNOPS(aTHX);
657 /*NORETURN*/
658 abort ();
659}
660
317STATIC void 661STATIC void
318S_nuke_stacks(pTHX) 662transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
319{ 663{
320 while (PL_curstackinfo->si_next) 664 dSP;
321 PL_curstackinfo = PL_curstackinfo->si_next; 665 dSTACKLEVEL;
322 while (PL_curstackinfo) { 666
323 PERL_SI *p = PL_curstackinfo->si_prev; 667 if (prev != next)
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 668 {
325 Safefree(PL_curstackinfo->si_cxstack); 669 if (next->mainstack)
326 Safefree(PL_curstackinfo); 670 {
327 PL_curstackinfo = p; 671 SAVE (prev, flags);
672 LOAD (next);
673
674 /* mark this state as in-use */
675 next->mainstack = 0;
676 next->tmps_ix = -2;
677
678 /* stacklevel changed? if yes, grab the stack for us! */
679 if (flags & TRANSFER_SAVE_CCTXT)
680 {
681 if (!prev->stack)
682 allocate_stack (prev, 0);
683 else if (prev->cursp != stacklevel
684 && prev->stack->usecnt > 1)
685 {
686 prev->gencnt = ++prev->stack->gencnt;
687 prev->stack->usecnt = 1;
688 }
689
690 /* has our stack been invalidated? */
691 if (next->stack && next->stack->gencnt != next->gencnt)
692 {
693 deallocate_stack (next);
694 allocate_stack (next, 1);
695 coro_create (&(next->stack->cctx),
696 continue_coro, (void *)next,
697 next->stack->sptr, labs (next->stack->ssize));
698 }
699
700 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
701 }
702
703 }
704 else if (next->tmps_ix == -2)
705 croak ("tried to transfer to running coroutine");
706 else
707 {
708 SAVE (prev, -1); /* first get rid of the old state */
709
710 if (flags & TRANSFER_SAVE_CCTXT)
711 {
712 if (!prev->stack)
713 allocate_stack (prev, 0);
714
715 if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
716 {
717 setup_coro (next);
718
719 prev->stack->refcnt++;
720 prev->stack->usecnt++;
721 next->stack = prev->stack;
722 next->gencnt = prev->gencnt;
723 }
724 else
725 {
726 allocate_stack (next, 1);
727 coro_create (&(next->stack->cctx),
728 setup_coro, (void *)next,
729 next->stack->sptr, labs (next->stack->ssize));
730 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
731 }
732 }
733 else
734 setup_coro (next);
735 }
328 } 736 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335 737
336#define SUB_INIT "Coro::State::_newcoro" 738 next->cursp = stacklevel;
739}
337 740
338MODULE = Coro::State PACKAGE = Coro::State 741MODULE = Coro::State PACKAGE = Coro::State
339 742
340PROTOTYPES: ENABLE 743PROTOTYPES: ENABLE
341 744
342BOOT: 745BOOT:
746{ /* {} necessary for stoopid perl-5.6.x */
747 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
748 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
749 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
750
751 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
752 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
753 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
754 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
755
343 if (!padlist_cache) 756 if (!padlist_cache)
344 padlist_cache = newHV (); 757 padlist_cache = newHV ();
758
759 main_mainstack = PL_mainstack;
760}
345 761
346Coro::State 762Coro::State
347_newprocess(args) 763_newprocess(args)
348 SV * args 764 SV * args
349 PROTOTYPE: $ 765 PROTOTYPE: $
350 CODE: 766 CODE:
351 Coro__State coro; 767 Coro__State coro;
352 768
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 769 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref"); 770 croak ("Coro::State::_newprocess expects an arrayref");
355 771
356 New (0, coro, 1, struct coro); 772 New (0, coro, 1, struct coro);
357 773
774 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358 coro->mainstack = 0; /* actual work is done inside transfer */ 775 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 776 coro->stack = 0;
360 777
361 RETVAL = coro; 778 RETVAL = coro;
362 OUTPUT: 779 OUTPUT:
363 RETVAL 780 RETVAL
364 781
365void 782void
366transfer(prev,next) 783transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
367 Coro::State_or_hashref prev 784 Coro::State_or_hashref prev
368 Coro::State_or_hashref next 785 Coro::State_or_hashref next
786 int flags
787 PROTOTYPE: @
369 CODE: 788 CODE:
370 789 transfer (aTHX_ prev, next, flags);
371 if (prev != next)
372 {
373 PUTBACK;
374 SAVE (aTHX_ prev);
375
376 /*
377 * this could be done in newprocess which would lead to
378 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379 * code here, but lazy allocation of stacks has also
380 * some virtues and the overhead of the if() is nil.
381 */
382 if (next->mainstack)
383 {
384 LOAD (aTHX_ next);
385 next->mainstack = 0; /* unnecessary but much cleaner */
386 SPAGAIN;
387 }
388 else
389 {
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394
395 init_stacks ();
396 PL_op = (OP *)&myop;
397 /*PL_curcop = 0;*/
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399
400 SPAGAIN;
401 Zero(&myop, 1, UNOP);
402 myop.op_next = Nullop;
403 myop.op_flags = OPf_WANT_VOID;
404
405 PUSHMARK(SP);
406 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407 PUTBACK;
408 /*
409 * the next line is slightly wrong, as PL_op->op_next
410 * is actually being executed so we skip the first op.
411 * that doesn't matter, though, since it is only
412 * pp_nextstate and we never return...
413 */
414 PL_op = Perl_pp_entersub(aTHX);
415 SPAGAIN;
416
417 ENTER;
418 }
419 }
420 790
421void 791void
422DESTROY(coro) 792DESTROY(coro)
423 Coro::State coro 793 Coro::State coro
424 CODE: 794 CODE:
425 795
426 if (coro->mainstack) 796 if (coro->mainstack && coro->mainstack != main_mainstack)
427 { 797 {
428 struct coro temp; 798 struct coro temp;
429 799
430 PUTBACK;
431 SAVE(aTHX_ (&temp)); 800 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432 LOAD(aTHX_ coro); 801 LOAD(aTHX_ coro);
433 802
434 S_nuke_stacks (); 803 destroy_stacks (aTHX);
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436 804
437 LOAD((&temp)); 805 LOAD((&temp)); /* this will get rid of defsv etc.. */
438 SPAGAIN; 806
807 coro->mainstack = 0;
439 } 808 }
440 809
441 SvREFCNT_dec (coro->args); 810 deallocate_stack (coro);
811
442 Safefree (coro); 812 Safefree (coro);
443 813
814void
815flush()
816 CODE:
817#ifdef MAY_FLUSH
818 flush_padlist_cache ();
819#endif
444 820
821MODULE = Coro::State PACKAGE = Coro::Cont
822
823# this is slightly dirty
824
825void
826yield(...)
827 PROTOTYPE: @
828 CODE:
829 static SV *returnstk;
830 SV *sv;
831 AV *defav = GvAV (PL_defgv);
832 struct coro *prev, *next;
833
834 if (!returnstk)
835 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
836
837 /* set up @_ -- ugly */
838 av_clear (defav);
839 av_fill (defav, items - 1);
840 while (items--)
841 av_store (defav, items, SvREFCNT_inc (ST(items)));
842
843 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
844 sv = av_pop ((AV *)SvRV (returnstk));
845 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
846 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
847 SvREFCNT_dec (sv);
848
849 transfer(aTHX_ prev, next, 0);
850

Diff Legend

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