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.32 by root, Sun Aug 26 17:01:54 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 labs(l) ((l) >= 0 ? (l) : -(l))
32
33#include "CoroAPI.h"
34
35static struct CoroAPI coroapi;
36
37/* this is actually not only the c stack but also c registers etc... */
38typedef struct {
39 int refcnt; /* pointer reference counter */
40 int usecnt; /* shared by how many coroutines */
41 int gencnt; /* generation counter */
42
43 coro_context cctx;
44
45 void *sptr;
46 long ssize; /* positive == mmap, otherwise malloc */
47} coro_stack;
48
11struct coro { 49struct coro {
50 /* the optional C context */
51 coro_stack *stack;
52 void *cursp;
53 int gencnt;
54
55 /* optionally saved, might be zero */
56 AV *defav;
57 SV *defsv;
58 SV *errsv;
59
60 /* saved global state not related to stacks */
12 U8 dowarn; 61 U8 dowarn;
13 AV *defav; 62 I32 in_eval;
14 63
64 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 65 PERL_SI *curstackinfo;
16 AV *curstack; 66 AV *curstack;
17 AV *mainstack; 67 AV *mainstack;
18 SV **stack_sp; 68 SV **stack_sp;
19 OP *op; 69 OP *op;
… …
35 I32 savestack_max; 85 I32 savestack_max;
36 OP **retstack; 86 OP **retstack;
37 I32 retstack_ix; 87 I32 retstack_ix;
38 I32 retstack_max; 88 I32 retstack_max;
39 COP *curcop; 89 COP *curcop;
90 JMPENV *top_env;
40 91
92 /* data associated with this coroutine (initial args) */
41 AV *args; 93 AV *args;
42}; 94};
43 95
44typedef struct coro *Coro__State; 96typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 97typedef struct coro *Coro__State_or_hashref;
46 98
99static AV *main_mainstack; /* used to differentiate between $main and others */
100static HV *coro_state_stash;
101static SV *ucoro_state_sv;
102static U32 ucoro_state_hash;
47static HV *padlist_cache; 103static HV *padlist_cache;
48 104
49/* mostly copied from op.c:cv_clone2 */ 105/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 106STATIC AV *
51clone_padlist (AV *protopadlist) 107clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 171 SvPADTMP_on (sv);
116 npad[ix] = sv; 172 npad[ix] = sv;
117 } 173 }
118 } 174 }
119 175
120#if 0 /* NONOTUNDERSTOOD */ 176#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 177 /* Now that vars are all in place, clone nested closures. */
122 178
123 for (ix = fpad; ix > 0; ix--) { 179 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 180 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 181 if (namesv
… …
138#endif 194#endif
139 195
140 return newpadlist; 196 return newpadlist;
141} 197}
142 198
143STATIC AV * 199#ifdef MAY_FLUSH
200STATIC void
144free_padlist (AV *padlist) 201free_padlist (AV *padlist)
145{ 202{
146 /* may be during global destruction */ 203 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 204 if (SvREFCNT(padlist))
148 { 205 {
… …
156 } 213 }
157 214
158 SvREFCNT_dec((SV*)padlist); 215 SvREFCNT_dec((SV*)padlist);
159 } 216 }
160} 217}
218#endif
161 219
162STATIC AV * 220/* the next two functions merely cache the padlists */
163unuse_padlist (AV *padlist) 221STATIC void
222get_padlist (CV *cv)
164{ 223{
224 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
225
226 if (he && AvFILLp ((AV *)*he) >= 0)
227 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
228 else
229 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
230}
231
232STATIC void
233put_padlist (CV *cv)
234{
235 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
236
237 if (SvTYPE (*he) != SVt_PVAV)
238 {
239 SvREFCNT_dec (*he);
240 *he = (SV *)newAV ();
241 }
242
243 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
244}
245
246#ifdef MAY_FLUSH
247STATIC void
248flush_padlist_cache ()
249{
250 HV *hv = padlist_cache;
251 padlist_cache = newHV ();
252
253 if (hv_iterinit (hv))
254 {
255 HE *he;
256 AV *padlist;
257
258 while (!!(he = hv_iternext (hv)))
259 {
260 AV *av = (AV *)HeVAL(he);
261
262 /* casting is fun. */
263 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
165 free_padlist (padlist); 264 free_padlist (padlist);
265 }
266 }
267
268 SvREFCNT_dec (hv);
166} 269}
270#endif
271
272#define SB do {
273#define SE } while (0)
274
275#define LOAD(state) load_state(aTHX_ (state));
276#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
277
278#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
167 279
168static void 280static void
169SAVE(pTHX_ Coro__State c) 281load_state(pTHX_ Coro__State c)
282{
283 PL_dowarn = c->dowarn;
284 PL_in_eval = c->in_eval;
285
286 PL_curstackinfo = c->curstackinfo;
287 PL_curstack = c->curstack;
288 PL_mainstack = c->mainstack;
289 PL_stack_sp = c->stack_sp;
290 PL_op = c->op;
291 PL_curpad = c->curpad;
292 PL_stack_base = c->stack_base;
293 PL_stack_max = c->stack_max;
294 PL_tmps_stack = c->tmps_stack;
295 PL_tmps_floor = c->tmps_floor;
296 PL_tmps_ix = c->tmps_ix;
297 PL_tmps_max = c->tmps_max;
298 PL_markstack = c->markstack;
299 PL_markstack_ptr = c->markstack_ptr;
300 PL_markstack_max = c->markstack_max;
301 PL_scopestack = c->scopestack;
302 PL_scopestack_ix = c->scopestack_ix;
303 PL_scopestack_max = c->scopestack_max;
304 PL_savestack = c->savestack;
305 PL_savestack_ix = c->savestack_ix;
306 PL_savestack_max = c->savestack_max;
307 PL_retstack = c->retstack;
308 PL_retstack_ix = c->retstack_ix;
309 PL_retstack_max = c->retstack_max;
310 PL_curcop = c->curcop;
311 PL_top_env = c->top_env;
312
313 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
314 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
315 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
316
317 {
318 dSP;
319 CV *cv;
320
321 /* now do the ugly restore mess */
322 while ((cv = (CV *)POPs))
323 {
324 AV *padlist = (AV *)POPs;
325
326 if (padlist)
327 {
328 put_padlist (cv); /* mark this padlist as available */
329 CvPADLIST(cv) = padlist;
330#ifdef USE_THREADS
331 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
332#endif
333 }
334
335 ++CvDEPTH(cv);
336 }
337
338 PUTBACK;
339 }
340}
341
342static void
343save_state(pTHX_ Coro__State c, int flags)
170{ 344{
171 { 345 {
172 dSP; 346 dSP;
173 I32 cxix = cxstack_ix; 347 I32 cxix = cxstack_ix;
348 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 349 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 350
177 /* 351 /*
178 * the worst thing you can imagine happens first - we have to save 352 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 353 * (and reinitialize) all cv's in the whole callchain :(
180 */ 354 */
… …
183 /* this loop was inspired by pp_caller */ 357 /* this loop was inspired by pp_caller */
184 for (;;) 358 for (;;)
185 { 359 {
186 while (cxix >= 0) 360 while (cxix >= 0)
187 { 361 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 362 PERL_CONTEXT *cx = &ccstk[cxix--];
189 363
190 if (CxTYPE(cx) == CXt_SUB) 364 if (CxTYPE(cx) == CXt_SUB)
191 { 365 {
192 CV *cv = cx->blk_sub.cv; 366 CV *cv = cx->blk_sub.cv;
193 if (CvDEPTH(cv)) 367 if (CvDEPTH(cv))
194 { 368 {
195#ifdef USE_THREADS 369#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv)); 370 /*XPUSHs ((SV *)CvOWNER(cv));*/
371 /*CvOWNER(cv) = 0;*/
372 /*error must unlock this cv etc.. etc...*/
197#endif 373#endif
198 EXTEND (SP, 3); 374 EXTEND (SP, CvDEPTH(cv)*2);
375
376 while (--CvDEPTH(cv))
377 {
378 /* this tells the restore code to increment CvDEPTH */
379 PUSHs (Nullsv);
199 PUSHs ((SV *)CvDEPTH(cv)); 380 PUSHs ((SV *)cv);
381 }
382
200 PUSHs ((SV *)CvPADLIST(cv)); 383 PUSHs ((SV *)CvPADLIST(cv));
201 PUSHs ((SV *)cv); 384 PUSHs ((SV *)cv);
202 385
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv)); 386 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 } 387 }
213 } 388 }
214 else if (CxTYPE(cx) == CXt_FORMAT) 389 else if (CxTYPE(cx) == CXt_FORMAT)
215 { 390 {
216 /* I never used formats, so how should I know how these are implemented? */ 391 /* I never used formats, so how should I know how these are implemented? */
… …
228 } 403 }
229 404
230 PUTBACK; 405 PUTBACK;
231 } 406 }
232 407
408 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
409 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
410 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
411
233 c->dowarn = PL_dowarn; 412 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 413 c->in_eval = PL_in_eval;
414
235 c->curstackinfo = PL_curstackinfo; 415 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack; 416 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack; 417 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp; 418 c->stack_sp = PL_stack_sp;
239 c->op = PL_op; 419 c->op = PL_op;
… …
255 c->savestack_max = PL_savestack_max; 435 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack; 436 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix; 437 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max; 438 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop; 439 c->curcop = PL_curcop;
440 c->top_env = PL_top_env;
441}
442
443/*
444 * allocate various perl stacks. This is an exact copy
445 * of perl.c:init_stacks, except that it uses less memory
446 * on the assumption that coroutines do not usually need
447 * a lot of stackspace.
448 */
449STATIC void
450coro_init_stacks (pTHX)
451{
452 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
453 PL_curstackinfo->si_type = PERLSI_MAIN;
454 PL_curstack = PL_curstackinfo->si_stack;
455 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
456
457 PL_stack_base = AvARRAY(PL_curstack);
458 PL_stack_sp = PL_stack_base;
459 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
460
461 New(50,PL_tmps_stack,96,SV*);
462 PL_tmps_floor = -1;
463 PL_tmps_ix = -1;
464 PL_tmps_max = 96;
465
466 New(54,PL_markstack,16,I32);
467 PL_markstack_ptr = PL_markstack;
468 PL_markstack_max = PL_markstack + 16;
469
470 SET_MARK_OFFSET;
471
472 New(54,PL_scopestack,16,I32);
473 PL_scopestack_ix = 0;
474 PL_scopestack_max = 16;
475
476 New(54,PL_savestack,96,ANY);
477 PL_savestack_ix = 0;
478 PL_savestack_max = 96;
479
480 New(54,PL_retstack,8,OP*);
481 PL_retstack_ix = 0;
482 PL_retstack_max = 8;
483}
484
485/*
486 * destroy the stacks, the callchain etc...
487 * still there is a memleak of 128 bytes...
488 */
489STATIC void
490destroy_stacks(pTHX)
491{
492 int destruct = PL_main_cv != Nullcv;
493
494 if (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 (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 /*
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
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) && SvSTASH(SvRV(arg)) == coro_state_stash)
774 return (struct coro *) SvIV((SV*)SvRV(arg));
775
776 croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
777 /*NORETURN*/
778}
779
780static void
781api_transfer(pTHX_ SV *prev, SV *next, int flags)
782{
783 transfer(aTHX_
784 sv_to_coro (prev, "Coro::transfer", "prev"),
785 sv_to_coro (next, "Coro::transfer", "next"),
786 flags);
787}
788
789/** Coro ********************************************************************/
790
791#define PRIO_MAX 3
792#define PRIO_HIGH 1
793#define PRIO_NORMAL 0
794#define PRIO_LOW -1
795#define PRIO_IDLE -3
796#define PRIO_MIN -4
797
798/* for Coro.pm */
799static GV *coro_current, *coro_idle;
800static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
801static int coro_nready;
802
803static void
804coro_enq (SV *sv)
805{
806 if (SvROK (sv))
807 {
808 SV *hv = SvRV (sv);
809 if (SvTYPE (hv) == SVt_PVHV)
810 {
811 SV **xprio = hv_fetch ((HV *)hv, "prio", 4, 0);
812 int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
813
814 prio = prio > PRIO_MAX ? PRIO_MAX
815 : prio < PRIO_MIN ? PRIO_MIN
816 : prio;
817
818 av_push (coro_ready [prio - PRIO_MIN], sv);
819 coro_nready++;
820
821 return;
822 }
823 }
824
825 croak ("Coro::ready tried to enqueue something that is not a coroutine");
826}
827
828static SV *
829coro_deq (int min_prio)
830{
831 int prio = PRIO_MAX - PRIO_MIN;
832
833 min_prio -= PRIO_MIN;
834 if (min_prio < 0)
835 min_prio = 0;
836
837 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
838 if (av_len (coro_ready[prio]) >= 0)
299 { 839 {
300 AV *padlist = (AV *)POPs; 840 coro_nready--;
301 841 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 } 842 }
311 843
312 PUTBACK; 844 return 0;
313 }
314} 845}
315 846
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 847static void
317STATIC void 848api_ready (SV *coro)
318S_nuke_stacks(pTHX)
319{ 849{
320 while (PL_curstackinfo->si_next) 850 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} 851}
335 852
336#define SUB_INIT "Coro::State::_newcoro" 853static void
854api_schedule (int cede)
855{
856 SV *prev, *next;
857
858 prev = GvSV (coro_current);
859
860 if (cede)
861 coro_enq (SvREFCNT_inc (prev));
862
863 next = coro_deq (PRIO_MIN);
864
865 if (!next)
866 next = SvREFCNT_inc (GvSV (coro_idle));
867
868 GvSV (coro_current) = SvREFCNT_inc (next);
869 transfer (aTHX_
870 sv_to_coro (prev, "Coro::schedule", "current coroutine"),
871 sv_to_coro (next, "Coro::schedule", "next coroutine"),
872 TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK);
873 SvREFCNT_dec (next);
874 SvREFCNT_dec (prev);
875}
337 876
338MODULE = Coro::State PACKAGE = Coro::State 877MODULE = Coro::State PACKAGE = Coro::State
339 878
340PROTOTYPES: ENABLE 879PROTOTYPES: ENABLE
341 880
342BOOT: 881BOOT:
882{ /* {} necessary for stoopid perl-5.6.x */
883 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
884 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
885 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
886
887 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
888 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
889 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
890 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
891
343 if (!padlist_cache) 892 if (!padlist_cache)
344 padlist_cache = newHV (); 893 padlist_cache = newHV ();
894
895 main_mainstack = PL_mainstack;
896
897 coroapi.ver = CORO_API_VERSION;
898 coroapi.transfer = api_transfer;
899}
345 900
346Coro::State 901Coro::State
347_newprocess(args) 902_newprocess(args)
348 SV * args 903 SV * args
349 PROTOTYPE: $ 904 PROTOTYPE: $
350 CODE: 905 CODE:
351 Coro__State coro; 906 Coro__State coro;
352 907
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 908 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref"); 909 croak ("Coro::State::_newprocess expects an arrayref");
355 910
356 New (0, coro, 1, struct coro); 911 New (0, coro, 1, struct coro);
357 912
913 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358 coro->mainstack = 0; /* actual work is done inside transfer */ 914 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 915 coro->stack = 0;
360 916
361 RETVAL = coro; 917 RETVAL = coro;
362 OUTPUT: 918 OUTPUT:
363 RETVAL 919 RETVAL
364 920
365void 921void
366transfer(prev,next) 922transfer(prev, next, flags)
367 Coro::State_or_hashref prev 923 Coro::State_or_hashref prev
368 Coro::State_or_hashref next 924 Coro::State_or_hashref next
925 int flags
926 PROTOTYPE: @
369 CODE: 927 CODE:
370
371 if (prev != next)
372 {
373 PUTBACK; 928 PUTBACK;
374 SAVE (aTHX_ prev); 929 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; 930 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 931
421void 932void
422DESTROY(coro) 933DESTROY(coro)
423 Coro::State coro 934 Coro::State coro
424 CODE: 935 CODE:
425 936
426 if (coro->mainstack) 937 if (coro->mainstack && coro->mainstack != main_mainstack)
427 { 938 {
428 struct coro temp; 939 struct coro temp;
429 940
430 PUTBACK; 941 PUTBACK;
431 SAVE(aTHX_ (&temp)); 942 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432 LOAD(aTHX_ coro); 943 LOAD(aTHX_ coro);
433
434 S_nuke_stacks ();
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN; 944 SPAGAIN;
945
946 destroy_stacks (aTHX);
947
948 LOAD((&temp)); /* this will get rid of defsv etc.. */
949 SPAGAIN;
950
951 coro->mainstack = 0;
439 } 952 }
440 953
441 SvREFCNT_dec (coro->args); 954 deallocate_stack (coro);
955
442 Safefree (coro); 956 Safefree (coro);
443 957
958void
959flush()
960 CODE:
961#ifdef MAY_FLUSH
962 flush_padlist_cache ();
963#endif
444 964
965void
966_exit(code)
967 int code
968 PROTOTYPE: $
969 CODE:
970#if defined(__GLIBC__) || _POSIX_C_SOURCE
971 _exit (code);
972#else
973 signal (SIGTERM, SIG_DFL);
974 raise (SIGTERM);
975 exit (code);
976#endif
977
978MODULE = Coro::State PACKAGE = Coro::Cont
979
980# this is slightly dirty (should expose a c-level api)
981
982void
983yield(...)
984 PROTOTYPE: @
985 CODE:
986 static SV *returnstk;
987 SV *sv;
988 AV *defav = GvAV (PL_defgv);
989 struct coro *prev, *next;
990
991 if (!returnstk)
992 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
993
994 /* set up @_ -- ugly */
995 av_clear (defav);
996 av_fill (defav, items - 1);
997 while (items--)
998 av_store (defav, items, SvREFCNT_inc (ST(items)));
999
1000 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
1001 sv = av_pop ((AV *)SvRV (returnstk));
1002 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
1003 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
1004 SvREFCNT_dec (sv);
1005
1006 transfer(aTHX_ prev, next, 0);
1007
1008MODULE = Coro::State PACKAGE = Coro
1009
1010# this is slightly dirty (should expose a c-level api)
1011
1012BOOT:
1013{
1014 int i;
1015 HV *stash = gv_stashpv ("Coro", TRUE);
1016
1017 newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
1018 newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1019 newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1020 newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
1021 newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1022 newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
1023
1024 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1025 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1026
1027 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1028 coro_ready[i] = newAV ();
1029
1030 {
1031 SV *sv = perl_get_sv("Coro::API", 1);
1032
1033 coroapi.schedule = api_schedule;
1034 coroapi.ready = api_ready;
1035 coroapi.nready = &coro_nready;
1036 coroapi.current = coro_current;
1037
1038 GCoroAPI = &coroapi;
1039 sv_setiv(sv, (IV)&coroapi);
1040 SvREADONLY_on(sv);
1041 }
1042}
1043
1044void
1045ready(self)
1046 SV * self
1047 CODE:
1048 api_ready (self);
1049
1050int
1051nready(...)
1052 PROTOTYPE:
1053 CODE:
1054 RETVAL = coro_nready;
1055 OUTPUT:
1056 RETVAL
1057
1058void
1059schedule(...)
1060 PROTOTYPE:
1061 ALIAS:
1062 cede = 1
1063 CODE:
1064 api_schedule (ix);
1065

Diff Legend

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