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

Diff Legend

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