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.35 by root, Mon Sep 24 01:36:20 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#include <signal.h>
8
9#ifdef HAVE_MMAP
10# include <unistd.h>
11# include <sys/mman.h>
12# ifndef MAP_ANON
13# ifdef MAP_ANONYMOUS
14# define MAP_ANON MAP_ANONYMOUS
7#else 15# else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 16# undef HAVE_MMAP
17# endif
18# endif
9#endif 19#endif
10 20
21#define MAY_FLUSH /* increases codesize and is rarely used */
22
23#define SUB_INIT "Coro::State::initialize"
24#define UCORO_STATE "_coro_state"
25
26/* The next macro should declare a variable stacklevel that contains and approximation
27 * to the current C stack pointer. Its property is that it changes with each call
28 * and should be unique. */
29#define dSTACKLEVEL void *stacklevel = &stacklevel
30
31#define IN_DESTRUCT (PL_main_cv == Nullcv)
32
33#define labs(l) ((l) >= 0 ? (l) : -(l))
34
35#include "CoroAPI.h"
36
37static struct CoroAPI coroapi;
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
11struct coro { 51struct coro {
52 /* the optional C context */
53 coro_stack *stack;
54 void *cursp;
55 int gencnt;
56
57 /* optionally saved, might be zero */
58 AV *defav;
59 SV *defsv;
60 SV *errsv;
61
62 /* saved global state not related to stacks */
12 U8 dowarn; 63 U8 dowarn;
13 AV *defav; 64 I32 in_eval;
14 65
66 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 67 PERL_SI *curstackinfo;
16 AV *curstack; 68 AV *curstack;
17 AV *mainstack; 69 AV *mainstack;
18 SV **stack_sp; 70 SV **stack_sp;
19 OP *op; 71 OP *op;
… …
35 I32 savestack_max; 87 I32 savestack_max;
36 OP **retstack; 88 OP **retstack;
37 I32 retstack_ix; 89 I32 retstack_ix;
38 I32 retstack_max; 90 I32 retstack_max;
39 COP *curcop; 91 COP *curcop;
92 JMPENV *top_env;
40 93
94 /* data associated with this coroutine (initial args) */
41 AV *args; 95 AV *args;
42}; 96};
43 97
44typedef struct coro *Coro__State; 98typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 99typedef struct coro *Coro__State_or_hashref;
46 100
101static AV *main_mainstack; /* used to differentiate between $main and others */
102static HV *coro_state_stash;
103static SV *ucoro_state_sv;
104static U32 ucoro_state_hash;
47static HV *padlist_cache; 105static HV *padlist_cache;
48 106
49/* mostly copied from op.c:cv_clone2 */ 107/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 108STATIC AV *
51clone_padlist (AV *protopadlist) 109clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 173 SvPADTMP_on (sv);
116 npad[ix] = sv; 174 npad[ix] = sv;
117 } 175 }
118 } 176 }
119 177
120#if 0 /* NONOTUNDERSTOOD */ 178#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 179 /* Now that vars are all in place, clone nested closures. */
122 180
123 for (ix = fpad; ix > 0; ix--) { 181 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 182 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 183 if (namesv
… …
138#endif 196#endif
139 197
140 return newpadlist; 198 return newpadlist;
141} 199}
142 200
143STATIC AV * 201#ifdef MAY_FLUSH
202STATIC void
144free_padlist (AV *padlist) 203free_padlist (AV *padlist)
145{ 204{
146 /* may be during global destruction */ 205 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 206 if (SvREFCNT(padlist))
148 { 207 {
… …
156 } 215 }
157 216
158 SvREFCNT_dec((SV*)padlist); 217 SvREFCNT_dec((SV*)padlist);
159 } 218 }
160} 219}
220#endif
161 221
162STATIC AV * 222/* the next two functions merely cache the padlists */
163unuse_padlist (AV *padlist) 223STATIC void
224get_padlist (CV *cv)
164{ 225{
226 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
227
228 if (he && AvFILLp ((AV *)*he) >= 0)
229 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
230 else
231 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
232}
233
234STATIC void
235put_padlist (CV *cv)
236{
237 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
238
239 if (SvTYPE (*he) != SVt_PVAV)
240 {
241 SvREFCNT_dec (*he);
242 *he = (SV *)newAV ();
243 }
244
245 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
246}
247
248#ifdef MAY_FLUSH
249STATIC void
250flush_padlist_cache ()
251{
252 HV *hv = padlist_cache;
253 padlist_cache = newHV ();
254
255 if (hv_iterinit (hv))
256 {
257 HE *he;
258 AV *padlist;
259
260 while (!!(he = hv_iternext (hv)))
261 {
262 AV *av = (AV *)HeVAL(he);
263
264 /* casting is fun. */
265 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
165 free_padlist (padlist); 266 free_padlist (padlist);
267 }
268 }
269
270 SvREFCNT_dec (hv);
166} 271}
272#endif
273
274#define SB do {
275#define SE } while (0)
276
277#define LOAD(state) load_state(aTHX_ (state));
278#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
279
280#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
167 281
168static void 282static void
169SAVE(pTHX_ Coro__State c) 283load_state(pTHX_ Coro__State c)
284{
285 PL_dowarn = c->dowarn;
286 PL_in_eval = c->in_eval;
287
288 PL_curstackinfo = c->curstackinfo;
289 PL_curstack = c->curstack;
290 PL_mainstack = c->mainstack;
291 PL_stack_sp = c->stack_sp;
292 PL_op = c->op;
293 PL_curpad = c->curpad;
294 PL_stack_base = c->stack_base;
295 PL_stack_max = c->stack_max;
296 PL_tmps_stack = c->tmps_stack;
297 PL_tmps_floor = c->tmps_floor;
298 PL_tmps_ix = c->tmps_ix;
299 PL_tmps_max = c->tmps_max;
300 PL_markstack = c->markstack;
301 PL_markstack_ptr = c->markstack_ptr;
302 PL_markstack_max = c->markstack_max;
303 PL_scopestack = c->scopestack;
304 PL_scopestack_ix = c->scopestack_ix;
305 PL_scopestack_max = c->scopestack_max;
306 PL_savestack = c->savestack;
307 PL_savestack_ix = c->savestack_ix;
308 PL_savestack_max = c->savestack_max;
309 PL_retstack = c->retstack;
310 PL_retstack_ix = c->retstack_ix;
311 PL_retstack_max = c->retstack_max;
312 PL_curcop = c->curcop;
313 PL_top_env = c->top_env;
314
315 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
316 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
317 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
318
319 {
320 dSP;
321 CV *cv;
322
323 /* now do the ugly restore mess */
324 while ((cv = (CV *)POPs))
325 {
326 AV *padlist = (AV *)POPs;
327
328 if (padlist)
329 {
330 put_padlist (cv); /* mark this padlist as available */
331 CvPADLIST(cv) = padlist;
332#ifdef USE_THREADS
333 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
334#endif
335 }
336
337 ++CvDEPTH(cv);
338 }
339
340 PUTBACK;
341 }
342}
343
344static void
345save_state(pTHX_ Coro__State c, int flags)
170{ 346{
171 { 347 {
172 dSP; 348 dSP;
173 I32 cxix = cxstack_ix; 349 I32 cxix = cxstack_ix;
350 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 351 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 352
177 /* 353 /*
178 * the worst thing you can imagine happens first - we have to save 354 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 355 * (and reinitialize) all cv's in the whole callchain :(
180 */ 356 */
… …
183 /* this loop was inspired by pp_caller */ 359 /* this loop was inspired by pp_caller */
184 for (;;) 360 for (;;)
185 { 361 {
186 while (cxix >= 0) 362 while (cxix >= 0)
187 { 363 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 364 PERL_CONTEXT *cx = &ccstk[cxix--];
189 365
190 if (CxTYPE(cx) == CXt_SUB) 366 if (CxTYPE(cx) == CXt_SUB)
191 { 367 {
192 CV *cv = cx->blk_sub.cv; 368 CV *cv = cx->blk_sub.cv;
193 if (CvDEPTH(cv)) 369 if (CvDEPTH(cv))
194 { 370 {
195#ifdef USE_THREADS 371#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv)); 372 /*XPUSHs ((SV *)CvOWNER(cv));*/
373 /*CvOWNER(cv) = 0;*/
374 /*error must unlock this cv etc.. etc...*/
197#endif 375#endif
198 EXTEND (SP, 3); 376 EXTEND (SP, CvDEPTH(cv)*2);
377
378 while (--CvDEPTH(cv))
379 {
380 /* this tells the restore code to increment CvDEPTH */
381 PUSHs (Nullsv);
199 PUSHs ((SV *)CvDEPTH(cv)); 382 PUSHs ((SV *)cv);
383 }
384
200 PUSHs ((SV *)CvPADLIST(cv)); 385 PUSHs ((SV *)CvPADLIST(cv));
201 PUSHs ((SV *)cv); 386 PUSHs ((SV *)cv);
202 387
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv)); 388 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 } 389 }
213 } 390 }
214 else if (CxTYPE(cx) == CXt_FORMAT) 391 else if (CxTYPE(cx) == CXt_FORMAT)
215 { 392 {
216 /* I never used formats, so how should I know how these are implemented? */ 393 /* I never used formats, so how should I know how these are implemented? */
… …
228 } 405 }
229 406
230 PUTBACK; 407 PUTBACK;
231 } 408 }
232 409
410 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
411 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
412 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
413
233 c->dowarn = PL_dowarn; 414 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 415 c->in_eval = PL_in_eval;
416
235 c->curstackinfo = PL_curstackinfo; 417 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack; 418 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack; 419 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp; 420 c->stack_sp = PL_stack_sp;
239 c->op = PL_op; 421 c->op = PL_op;
… …
255 c->savestack_max = PL_savestack_max; 437 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack; 438 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix; 439 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max; 440 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop; 441 c->curcop = PL_curcop;
442 c->top_env = PL_top_env;
443}
444
445/*
446 * allocate various perl stacks. This is an exact copy
447 * of perl.c:init_stacks, except that it uses less memory
448 * on the assumption that coroutines do not usually need
449 * a lot of stackspace.
450 */
451STATIC void
452coro_init_stacks (pTHX)
453{
454 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
455 PL_curstackinfo->si_type = PERLSI_MAIN;
456 PL_curstack = PL_curstackinfo->si_stack;
457 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
458
459 PL_stack_base = AvARRAY(PL_curstack);
460 PL_stack_sp = PL_stack_base;
461 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
462
463 New(50,PL_tmps_stack,96,SV*);
464 PL_tmps_floor = -1;
465 PL_tmps_ix = -1;
466 PL_tmps_max = 96;
467
468 New(54,PL_markstack,16,I32);
469 PL_markstack_ptr = PL_markstack;
470 PL_markstack_max = PL_markstack + 16;
471
472 SET_MARK_OFFSET;
473
474 New(54,PL_scopestack,16,I32);
475 PL_scopestack_ix = 0;
476 PL_scopestack_max = 16;
477
478 New(54,PL_savestack,96,ANY);
479 PL_savestack_ix = 0;
480 PL_savestack_max = 96;
481
482 New(54,PL_retstack,8,OP*);
483 PL_retstack_ix = 0;
484 PL_retstack_max = 8;
485}
486
487/*
488 * destroy the stacks, the callchain etc...
489 * still there is a memleak of 128 bytes...
490 */
491STATIC void
492destroy_stacks(pTHX)
493{
494 if (!IN_DESTRUCT)
495 {
496 /* is this ugly, I ask? */
497 while (PL_scopestack_ix)
498 LEAVE;
499
500 /* sure it is, but more important: is it correct?? :/ */
501 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
502 FREETMPS;
503 }
504
505 while (PL_curstackinfo->si_next)
506 PL_curstackinfo = PL_curstackinfo->si_next;
507
508 while (PL_curstackinfo)
509 {
510 PERL_SI *p = PL_curstackinfo->si_prev;
511
512 {
513 dSP;
514 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
515 PUTBACK; /* possibly superfluous */
516 }
517
518 if (!IN_DESTRUCT)
519 {
520 dounwind(-1);
521 SvREFCNT_dec(PL_curstackinfo->si_stack);
522 }
523
524 Safefree(PL_curstackinfo->si_cxstack);
525 Safefree(PL_curstackinfo);
526 PL_curstackinfo = p;
527 }
528
529 Safefree(PL_tmps_stack);
530 Safefree(PL_markstack);
531 Safefree(PL_scopestack);
532 Safefree(PL_savestack);
533 Safefree(PL_retstack);
260} 534}
261 535
262static void 536static void
263LOAD(pTHX_ Coro__State c) 537allocate_stack (Coro__State ctx, int alloc)
264{ 538{
265 PL_dowarn = c->dowarn; 539 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 540
541 New (0, stack, 1, coro_stack);
542
543 stack->refcnt = 1;
544 stack->usecnt = 1;
545 stack->gencnt = ctx->gencnt = 0;
546 if (alloc)
293 { 547 {
548#ifdef HAVE_MMAP
549 stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
550 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
551 if (stack->sptr == (void *)-1)
552#endif
553 {
554 /*FIXME*//*D*//* reasonable stack size! */
555 stack->ssize = -4096 * sizeof (long);
556 New (0, stack->sptr, 4096, long);
557 }
558 }
559 else
560 stack->sptr = 0;
561
562 ctx->stack = stack;
563}
564
565static void
566deallocate_stack (Coro__State ctx)
567{
568 coro_stack *stack = ctx->stack;
569
570 ctx->stack = 0;
571
572 if (stack)
573 {
574 if (!--stack->refcnt)
575 {
576#ifdef HAVE_MMAP
577 if (stack->ssize > 0 && stack->sptr)
578 munmap (stack->sptr, stack->ssize);
579 else
580#else
581 Safefree (stack->sptr);
582#endif
583 Safefree (stack);
584 }
585 else if (ctx->gencnt == stack->gencnt)
586 --stack->usecnt;
587 }
588}
589
590static void
591setup_coro (void *arg)
592{
593 /*
594 * emulate part of the perl startup here.
595 */
294 dSP; 596 dSP;
295 CV *cv; 597 Coro__State ctx = (Coro__State)arg;
598 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
296 599
297 /* now do the ugly restore mess */ 600 coro_init_stacks (aTHX);
298 while ((cv = (CV *)POPs)) 601 /*PL_curcop = 0;*/
602 /*PL_in_eval = PL_in_eval;*/ /* inherit */
603 SvREFCNT_dec (GvAV (PL_defgv));
604 GvAV (PL_defgv) = ctx->args;
605
606 SPAGAIN;
607
608 if (ctx->stack)
609 {
610 ctx->cursp = 0;
611
612 PUSHMARK(SP);
613 PUTBACK;
614 (void) call_sv (sub_init, G_VOID|G_NOARGS|G_EVAL);
615
616 if (SvTRUE (ERRSV))
617 croak (NULL);
618 else
619 croak ("FATAL: CCTXT coroutine returned!");
620 }
621 else
622 {
623 UNOP myop;
624
625 PL_op = (OP *)&myop;
626
627 Zero(&myop, 1, UNOP);
628 myop.op_next = Nullop;
629 myop.op_flags = OPf_WANT_VOID;
630
631 PUSHMARK(SP);
632 XPUSHs (sub_init);
633 /*
634 * the next line is slightly wrong, as PL_op->op_next
635 * is actually being executed so we skip the first op.
636 * that doesn't matter, though, since it is only
637 * pp_nextstate and we never return...
638 * ah yes, and I don't care anyways ;)
639 */
640 PUTBACK;
641 PL_op = pp_entersub();
642 SPAGAIN;
643
644 ENTER; /* necessary e.g. for dounwind */
645 }
646}
647
648static void
649continue_coro (void *arg)
650{
651 /*
652 * this is a _very_ stripped down perl interpreter ;)
653 */
654 Coro__State ctx = (Coro__State)arg;
655 JMPENV coro_start_env;
656
657 /* same as JMPENV_BOOTSTRAP */
658 Zero(&coro_start_env, 1, JMPENV);
659 coro_start_env.je_ret = -1;
660 coro_start_env.je_mustcatch = TRUE;
661 PL_top_env = &coro_start_env;
662
663 ctx->cursp = 0;
664 PL_op = PL_op->op_next;
665 CALLRUNOPS(aTHX);
666
667 abort ();
668}
669
670STATIC void
671transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
672{
673 dSTACKLEVEL;
674 static struct coro *xnext;
675
676 if (prev != next)
677 {
678 xnext = next;
679
680 if (next->mainstack)
681 {
682 SAVE (prev, flags);
683 LOAD (next);
684
685 /* mark this state as in-use */
686 next->mainstack = 0;
687 next->tmps_ix = -2;
688
689 /* stacklevel changed? if yes, grab the stack for us! */
690 if (flags & TRANSFER_SAVE_CCTXT)
691 {
692 if (!prev->stack)
693 allocate_stack (prev, 0);
694 else if (prev->cursp != stacklevel
695 && prev->stack->usecnt > 1)
696 {
697 prev->gencnt = ++prev->stack->gencnt;
698 prev->stack->usecnt = 1;
699 }
700
701 /* has our stack been invalidated? */
702 if (next->stack && next->stack->gencnt != next->gencnt)
703 {
704 deallocate_stack (next);
705 allocate_stack (next, 1);
706 coro_create (&(next->stack->cctx),
707 continue_coro, (void *)next,
708 next->stack->sptr, labs (next->stack->ssize));
709 }
710
711 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
712 /* don't add any code here */
713 }
714
715 }
716 else if (next->tmps_ix == -2)
717 croak ("tried to transfer to running coroutine");
718 else
719 {
720 SAVE (prev, -1); /* first get rid of the old state */
721
722 if (flags & TRANSFER_SAVE_CCTXT)
723 {
724 if (!prev->stack)
725 allocate_stack (prev, 0);
726
727 if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
728 {
729 setup_coro (next);
730
731 prev->stack->refcnt++;
732 prev->stack->usecnt++;
733 next->stack = prev->stack;
734 next->gencnt = prev->gencnt;
735 }
736 else
737 {
738 allocate_stack (next, 1);
739 coro_create (&(next->stack->cctx),
740 setup_coro, (void *)next,
741 next->stack->sptr, labs (next->stack->ssize));
742 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
743 /* don't add any code here */
744 }
745 }
746 else
747 setup_coro (next);
748 }
749
750 /*
751 * xnext is now either prev or next, depending on wether
752 * we switched the c stack or not. that's why i use a global
753 * variable, that should become thread-specific at one point.
754 */
755 xnext->cursp = stacklevel;
756 }
757}
758
759static struct coro *
760sv_to_coro (SV *arg, const char *funcname, const char *varname)
761{
762 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
763 {
764 HE *he = hv_fetch_ent((HV *)SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
765
766 if (!he)
767 croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
768
769 arg = HeVAL(he);
770 }
771
772 /* must also be changed inside Coro::Cont::yield */
773 if (SvROK(arg) && SvOBJECT(SvRV(arg))
774 && SvSTASH(SvRV(arg)) == coro_state_stash)
775 return (struct coro *) SvIV((SV*)SvRV(arg));
776
777 croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
778 /*NORETURN*/
779}
780
781static void
782api_transfer(pTHX_ SV *prev, SV *next, int flags)
783{
784 transfer(aTHX_
785 sv_to_coro (prev, "Coro::transfer", "prev"),
786 sv_to_coro (next, "Coro::transfer", "next"),
787 flags);
788}
789
790/** Coro ********************************************************************/
791
792#define PRIO_MAX 3
793#define PRIO_HIGH 1
794#define PRIO_NORMAL 0
795#define PRIO_LOW -1
796#define PRIO_IDLE -3
797#define PRIO_MIN -4
798
799/* for Coro.pm */
800static GV *coro_current, *coro_idle;
801static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
802static int coro_nready;
803
804static void
805coro_enq (SV *sv)
806{
807 if (SvROK (sv))
808 {
809 SV *hv = SvRV (sv);
810 if (SvTYPE (hv) == SVt_PVHV)
811 {
812 SV **xprio = hv_fetch ((HV *)hv, "prio", 4, 0);
813 int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
814
815 prio = prio > PRIO_MAX ? PRIO_MAX
816 : prio < PRIO_MIN ? PRIO_MIN
817 : prio;
818
819 av_push (coro_ready [prio - PRIO_MIN], sv);
820 coro_nready++;
821
822 return;
823 }
824 }
825
826 croak ("Coro::ready tried to enqueue something that is not a coroutine");
827}
828
829static SV *
830coro_deq (int min_prio)
831{
832 int prio = PRIO_MAX - PRIO_MIN;
833
834 min_prio -= PRIO_MIN;
835 if (min_prio < 0)
836 min_prio = 0;
837
838 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
839 if (av_len (coro_ready[prio]) >= 0)
299 { 840 {
300 AV *padlist = (AV *)POPs; 841 coro_nready--;
301 842 return av_shift (coro_ready[prio]);
302 unuse_padlist (CvPADLIST(cv));
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 } 843 }
311 844
312 PUTBACK; 845 return 0;
313 }
314} 846}
315 847
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 848static void
317STATIC void 849api_ready (SV *coro)
318S_nuke_stacks(pTHX)
319{ 850{
320 while (PL_curstackinfo->si_next) 851 coro_enq (SvREFCNT_inc (coro));
321 PL_curstackinfo = PL_curstackinfo->si_next;
322 while (PL_curstackinfo) {
323 PERL_SI *p = PL_curstackinfo->si_prev;
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
325 Safefree(PL_curstackinfo->si_cxstack);
326 Safefree(PL_curstackinfo);
327 PL_curstackinfo = p;
328 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334} 852}
335 853
336#define SUB_INIT "Coro::State::_newcoro" 854static void
855api_schedule (int cede)
856{
857 SV *prev, *next;
858
859 prev = GvSV (coro_current);
860
861 if (cede)
862 coro_enq (SvREFCNT_inc (prev));
863
864 next = coro_deq (PRIO_MIN);
865
866 if (!next)
867 next = SvREFCNT_inc (GvSV (coro_idle));
868
869 GvSV (coro_current) = SvREFCNT_inc (next);
870 transfer (aTHX_
871 sv_to_coro (prev, "Coro::schedule", "current coroutine"),
872 sv_to_coro (next, "Coro::schedule", "next coroutine"),
873 TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK);
874 SvREFCNT_dec (next);
875 SvREFCNT_dec (prev);
876}
337 877
338MODULE = Coro::State PACKAGE = Coro::State 878MODULE = Coro::State PACKAGE = Coro::State
339 879
340PROTOTYPES: ENABLE 880PROTOTYPES: ENABLE
341 881
342BOOT: 882BOOT:
883{ /* {} necessary for stoopid perl-5.6.x */
884 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
885 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
886 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
887
888 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
889 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
890 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
891 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
892
343 if (!padlist_cache) 893 if (!padlist_cache)
344 padlist_cache = newHV (); 894 padlist_cache = newHV ();
895
896 main_mainstack = PL_mainstack;
897
898 coroapi.ver = CORO_API_VERSION;
899 coroapi.transfer = api_transfer;
900}
345 901
346Coro::State 902Coro::State
347_newprocess(args) 903_newprocess(args)
348 SV * args 904 SV * args
349 PROTOTYPE: $ 905 PROTOTYPE: $
350 CODE: 906 CODE:
351 Coro__State coro; 907 Coro__State coro;
352 908
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 909 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref"); 910 croak ("Coro::State::_newprocess expects an arrayref");
355 911
356 New (0, coro, 1, struct coro); 912 New (0, coro, 1, struct coro);
357 913
914 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358 coro->mainstack = 0; /* actual work is done inside transfer */ 915 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 916 coro->stack = 0;
360 917
361 RETVAL = coro; 918 RETVAL = coro;
362 OUTPUT: 919 OUTPUT:
363 RETVAL 920 RETVAL
364 921
365void 922void
366transfer(prev,next) 923transfer(prev, next, flags)
367 Coro::State_or_hashref prev 924 Coro::State_or_hashref prev
368 Coro::State_or_hashref next 925 Coro::State_or_hashref next
926 int flags
927 PROTOTYPE: @
369 CODE: 928 CODE:
370
371 if (prev != next)
372 {
373 PUTBACK; 929 PUTBACK;
374 SAVE (aTHX_ prev); 930 transfer (aTHX_ prev, next, flags);
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; 931 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 932
421void 933void
422DESTROY(coro) 934DESTROY(coro)
423 Coro::State coro 935 Coro::State coro
424 CODE: 936 CODE:
425 937
426 if (coro->mainstack) 938 if (coro->mainstack && coro->mainstack != main_mainstack)
427 { 939 {
428 struct coro temp; 940 struct coro temp;
429 941
430 PUTBACK; 942 PUTBACK;
431 SAVE(aTHX_ (&temp)); 943 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432 LOAD(aTHX_ coro); 944 LOAD(aTHX_ coro);
433
434 S_nuke_stacks ();
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN; 945 SPAGAIN;
946
947 destroy_stacks (aTHX);
948
949 LOAD((&temp)); /* this will get rid of defsv etc.. */
950 SPAGAIN;
951
952 coro->mainstack = 0;
439 } 953 }
440 954
441 SvREFCNT_dec (coro->args); 955 deallocate_stack (coro);
956
442 Safefree (coro); 957 Safefree (coro);
443 958
959void
960flush()
961 CODE:
962#ifdef MAY_FLUSH
963 flush_padlist_cache ();
964#endif
444 965
966void
967_exit(code)
968 int code
969 PROTOTYPE: $
970 CODE:
971#if defined(__GLIBC__) || _POSIX_C_SOURCE
972 _exit (code);
973#else
974 signal (SIGTERM, SIG_DFL);
975 raise (SIGTERM);
976 exit (code);
977#endif
978
979MODULE = Coro::State PACKAGE = Coro::Cont
980
981# this is slightly dirty (should expose a c-level api)
982
983void
984yield(...)
985 PROTOTYPE: @
986 CODE:
987 static SV *returnstk;
988 SV *sv;
989 AV *defav = GvAV (PL_defgv);
990 struct coro *prev, *next;
991
992 if (!returnstk)
993 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
994
995 /* set up @_ -- ugly */
996 av_clear (defav);
997 av_fill (defav, items - 1);
998 while (items--)
999 av_store (defav, items, SvREFCNT_inc (ST(items)));
1000
1001 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
1002 sv = av_pop ((AV *)SvRV (returnstk));
1003 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
1004 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
1005 SvREFCNT_dec (sv);
1006
1007 transfer(aTHX_ prev, next, 0);
1008
1009MODULE = Coro::State PACKAGE = Coro
1010
1011# this is slightly dirty (should expose a c-level api)
1012
1013BOOT:
1014{
1015 int i;
1016 HV *stash = gv_stashpv ("Coro", TRUE);
1017
1018 newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
1019 newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1020 newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1021 newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
1022 newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1023 newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
1024
1025 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1026 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1027
1028 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1029 coro_ready[i] = newAV ();
1030
1031 {
1032 SV *sv = perl_get_sv("Coro::API", 1);
1033
1034 coroapi.schedule = api_schedule;
1035 coroapi.ready = api_ready;
1036 coroapi.nready = &coro_nready;
1037 coroapi.current = coro_current;
1038
1039 GCoroAPI = &coroapi;
1040 sv_setiv(sv, (IV)&coroapi);
1041 SvREADONLY_on(sv);
1042 }
1043}
1044
1045void
1046ready(self)
1047 SV * self
1048 PROTOTYPE: $
1049 CODE:
1050 api_ready (self);
1051
1052int
1053nready(...)
1054 PROTOTYPE:
1055 CODE:
1056 RETVAL = coro_nready;
1057 OUTPUT:
1058 RETVAL
1059
1060void
1061schedule(...)
1062 PROTOTYPE:
1063 ALIAS:
1064 cede = 1
1065 CODE:
1066 api_schedule (ix);
1067

Diff Legend

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