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.25 by root, Wed Aug 15 03:24:07 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 */
22
23#define SUB_INIT "Coro::State::initialize"
24#define UCORO_STATE "_coro_state"
25
26/* The next macro should delcare 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
199#ifdef MAY_FLUSH
143STATIC AV * 200STATIC AV *
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))
… …
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) SB load_state(aTHX_ (state)); SPAGAIN; SE
276#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
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 */
181 355
182 PUSHs (Nullsv); 356 PUSHs (Nullsv);
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 do
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? */
217 /* my bold guess is as a simple, plain sub... */ 392 /* my bold guess is as a simple, plain sub... */
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 393 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219 } 394 }
220 } 395 }
396 while (cxix >= 0);
221 397
222 if (top_si->si_type == PERLSI_MAIN) 398 if (top_si->si_type == PERLSI_MAIN)
223 break; 399 break;
224 400
225 top_si = top_si->si_prev; 401 top_si = top_si->si_prev;
… …
228 } 404 }
229 405
230 PUTBACK; 406 PUTBACK;
231 } 407 }
232 408
409 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
410 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
411 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
412
413 /* I have not the slightest idea of why av_reify is necessary */
414 /* but if it's missing the defav contents magically get replaced sometimes */
415 if (c->defav)
416 av_reify (c->defav);
417
233 c->dowarn = PL_dowarn; 418 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 419 c->in_eval = PL_in_eval;
420
235 c->curstackinfo = PL_curstackinfo; 421 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack; 422 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack; 423 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp; 424 c->stack_sp = PL_stack_sp;
239 c->op = PL_op; 425 c->op = PL_op;
… …
255 c->savestack_max = PL_savestack_max; 441 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack; 442 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix; 443 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max; 444 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop; 445 c->curcop = PL_curcop;
446 c->top_env = PL_top_env;
447}
448
449/*
450 * allocate various perl stacks. This is an exact copy
451 * of perl.c:init_stacks, except that it uses less memory
452 * on the assumption that coroutines do not usually need
453 * a lot of stackspace.
454 */
455STATIC void
456coro_init_stacks (pTHX)
457{
458 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
459 PL_curstackinfo->si_type = PERLSI_MAIN;
460 PL_curstack = PL_curstackinfo->si_stack;
461 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
462
463 PL_stack_base = AvARRAY(PL_curstack);
464 PL_stack_sp = PL_stack_base;
465 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
466
467 New(50,PL_tmps_stack,96,SV*);
468 PL_tmps_floor = -1;
469 PL_tmps_ix = -1;
470 PL_tmps_max = 96;
471
472 New(54,PL_markstack,16,I32);
473 PL_markstack_ptr = PL_markstack;
474 PL_markstack_max = PL_markstack + 16;
475
476 SET_MARK_OFFSET;
477
478 New(54,PL_scopestack,16,I32);
479 PL_scopestack_ix = 0;
480 PL_scopestack_max = 16;
481
482 New(54,PL_savestack,96,ANY);
483 PL_savestack_ix = 0;
484 PL_savestack_max = 96;
485
486 New(54,PL_retstack,8,OP*);
487 PL_retstack_ix = 0;
488 PL_retstack_max = 8;
489}
490
491/*
492 * destroy the stacks, the callchain etc...
493 * still there is a memleak of 128 bytes...
494 */
495STATIC void
496destroy_stacks(pTHX)
497{
498 /* is this ugly, I ask? */
499 while (PL_scopestack_ix)
500 LEAVE;
501
502 /* sure it is, but more important: is it correct?? :/ */
503 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
504 FREETMPS;
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 (PL_main_cv != Nullcv) /* don't during destruction. hack? */
520 dounwind(-1);
521
522 SvREFCNT_dec(PL_curstackinfo->si_stack);
523 Safefree(PL_curstackinfo->si_cxstack);
524 Safefree(PL_curstackinfo);
525 PL_curstackinfo = p;
526 }
527
528 Safefree(PL_tmps_stack);
529 Safefree(PL_markstack);
530 Safefree(PL_scopestack);
531 Safefree(PL_savestack);
532 Safefree(PL_retstack);
260} 533}
261 534
262static void 535static void
263LOAD(pTHX_ Coro__State c) 536allocate_stack (Coro__State ctx, int alloc)
264{ 537{
265 PL_dowarn = c->dowarn; 538 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 539
540 New (0, stack, 1, coro_stack);
541
542 stack->refcnt = 1;
543 stack->usecnt = 1;
544 stack->gencnt = ctx->gencnt = 0;
545 if (alloc)
293 { 546 {
547#ifdef HAVE_MMAP
548 stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
549 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
550 if (stack->sptr == (void *)-1)
551#endif
552 {
553 /*FIXME*//*D*//* reasonable stack size! */
554 stack->ssize = -4096 * sizeof (long);
555 New (0, stack->sptr, 4096, long);
556 }
557 }
558 else
559 stack->sptr = 0;
560
561 ctx->stack = stack;
562}
563
564static void
565deallocate_stack (Coro__State ctx)
566{
567 coro_stack *stack = ctx->stack;
568
569 ctx->stack = 0;
570
571 if (stack)
572 {
573 if (!--stack->refcnt)
574 {
575#ifdef HAVE_MMAP
576 if (stack->ssize > 0 && stack->sptr)
577 munmap (stack->sptr, stack->ssize);
578 else
579#else
580 Safefree (stack->sptr);
581#endif
582 Safefree (stack);
583 }
584 else if (ctx->gencnt == stack->gencnt)
585 --stack->usecnt;
586 }
587}
588
589static void
590setup_coro (void *arg)
591{
592 /*
593 * emulate part of the perl startup here.
594 */
294 dSP; 595 dSP;
295 CV *cv; 596 Coro__State ctx = (Coro__State)arg;
597 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
296 598
297 /* now do the ugly restore mess */ 599 coro_init_stacks (aTHX);
298 while ((cv = (CV *)POPs)) 600 /*PL_curcop = 0;*/
601 /*PL_in_eval = PL_in_eval;*/ /* inherit */
602 SvREFCNT_dec (GvAV (PL_defgv));
603 GvAV (PL_defgv) = ctx->args;
604
605 SPAGAIN;
606
607 if (ctx->stack)
608 {
609 ctx->cursp = 0;
610
611 PUSHMARK(SP);
612 PUTBACK;
613 (void) call_sv (sub_init, G_VOID|G_NOARGS|G_EVAL);
614
615 if (SvTRUE (ERRSV))
616 croak (NULL);
617 else
618 croak ("FATAL: CCTXT coroutine returned!");
619 }
620 else
621 {
622 UNOP myop;
623
624 PL_op = (OP *)&myop;
625
626 Zero(&myop, 1, UNOP);
627 myop.op_next = Nullop;
628 myop.op_flags = OPf_WANT_VOID;
629
630 PUSHMARK(SP);
631 XPUSHs (sub_init);
632 /*
633 * the next line is slightly wrong, as PL_op->op_next
634 * is actually being executed so we skip the first op.
635 * that doesn't matter, though, since it is only
636 * pp_nextstate and we never return...
637 * ah yes, and I don't care anyways ;)
638 */
639 PUTBACK;
640 PL_op = pp_entersub();
641 SPAGAIN;
642
643 ENTER; /* necessary e.g. for dounwind */
644 }
645}
646
647static void
648continue_coro (void *arg)
649{
650 /*
651 * this is a _very_ stripped down perl interpreter ;)
652 */
653 Coro__State ctx = (Coro__State)arg;
654
655 /*FIXME*//* must set up top_env here */
656 ctx->cursp = 0;
657 PL_op = PL_op->op_next;
658 CALLRUNOPS(aTHX);
659
660 abort ();
661}
662
663STATIC void
664transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
665{
666 dSP;
667 dSTACKLEVEL;
668
669 if (prev != next)
670 {
671 if (next->mainstack)
672 {
673 SAVE (prev, flags);
674 LOAD (next);
675
676 /* mark this state as in-use */
677 next->mainstack = 0;
678 next->tmps_ix = -2;
679
680 /* stacklevel changed? if yes, grab the stack for us! */
681 if (flags & TRANSFER_SAVE_CCTXT)
682 {
683 if (!prev->stack)
684 allocate_stack (prev, 0);
685 else if (prev->cursp != stacklevel
686 && prev->stack->usecnt > 1)
687 {
688 prev->gencnt = ++prev->stack->gencnt;
689 prev->stack->usecnt = 1;
690 }
691
692 /* has our stack been invalidated? */
693 if (next->stack && next->stack->gencnt != next->gencnt)
694 {
695 deallocate_stack (next);
696 allocate_stack (next, 1);
697 coro_create (&(next->stack->cctx),
698 continue_coro, (void *)next,
699 next->stack->sptr, labs (next->stack->ssize));
700 }
701
702 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
703 }
704
705 }
706 else if (next->tmps_ix == -2)
707 croak ("tried to transfer to running coroutine");
708 else
709 {
710 SAVE (prev, -1); /* first get rid of the old state */
711
712 if (flags & TRANSFER_SAVE_CCTXT)
713 {
714 if (!prev->stack)
715 allocate_stack (prev, 0);
716
717 if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
718 {
719 setup_coro (next);
720
721 prev->stack->refcnt++;
722 prev->stack->usecnt++;
723 next->stack = prev->stack;
724 next->gencnt = prev->gencnt;
725 }
726 else
727 {
728 allocate_stack (next, 1);
729 coro_create (&(next->stack->cctx),
730 setup_coro, (void *)next,
731 next->stack->sptr, labs (next->stack->ssize));
732 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
733 }
734 }
735 else
736 setup_coro (next);
737 }
738 }
739
740 next->cursp = stacklevel;
741}
742
743static struct coro *
744sv_to_coro (SV *arg, const char *funcname, const char *varname)
745{
746 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
747 {
748 HE *he = hv_fetch_ent((HV *)SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
749
750 if (!he)
751 croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
752
753 arg = HeVAL(he);
754 }
755
756 /* must also be changed inside Coro::Cont::yield */
757 if (SvROK(arg) && SvSTASH(SvRV(arg)) == coro_state_stash)
758 return (struct coro *) SvIV((SV*)SvRV(arg));
759 else
760 croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
761}
762
763static void
764api_transfer(pTHX_ SV *prev, SV *next, int flags)
765{
766 transfer(aTHX_ sv_to_coro (prev, "Coro::transfer", "prev"),
767 sv_to_coro (next, "Coro::transfer", "next"),
768 flags);
769}
770
771/** Coro ********************************************************************/
772
773#define PRIO_MAX 3
774#define PRIO_HIGH 1
775#define PRIO_NORMAL 0
776#define PRIO_LOW -1
777#define PRIO_IDLE -3
778#define PRIO_MIN -4
779
780/* for Coro.pm */
781static GV *coro_current, *coro_idle;
782static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
783static int coro_nready;
784
785static void
786coro_enq (SV *sv)
787{
788 if (SvROK (sv))
789 {
790 SV *hv = SvRV (sv);
791 if (SvTYPE (hv) == SVt_PVHV)
792 {
793 SV **xprio = hv_fetch ((HV *)hv, "prio", 4, 0);
794 int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
795
796 prio = prio > PRIO_MAX ? PRIO_MAX
797 : prio < PRIO_MIN ? PRIO_MIN
798 : prio;
799
800 av_push (coro_ready [prio - PRIO_MIN], sv);
801 coro_nready++;
802
803 return;
804 }
805 }
806
807 croak ("Coro::ready tried to enqueue something that is not a coroutine");
808}
809
810static SV *
811coro_deq (int min_prio)
812{
813 int prio = PRIO_MAX - PRIO_MIN;
814
815 min_prio -= PRIO_MIN;
816 if (min_prio < 0)
817 min_prio = 0;
818
819 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
820 if (av_len (coro_ready[prio]) >= 0)
299 { 821 {
300 AV *padlist = (AV *)POPs; 822 coro_nready--;
301 823 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 } 824 }
311 825
312 PUTBACK; 826 return 0;
313 }
314} 827}
315 828
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 829static void
317STATIC void 830api_ready (SV *coro)
318S_nuke_stacks(pTHX)
319{ 831{
320 while (PL_curstackinfo->si_next) 832 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} 833}
335 834
336#define SUB_INIT "Coro::State::_newcoro" 835static void
836api_schedule (int cede)
837{
838 SV *prev, *next;
839
840 prev = GvSV (coro_current);
841
842 if (cede)
843 coro_enq (SvREFCNT_inc (prev));
844
845 next = coro_deq (PRIO_MIN);
846
847 if (!next)
848 next = SvREFCNT_inc (GvSV (coro_idle));
849
850 GvSV (coro_current) = SvREFCNT_inc (next);
851 transfer (sv_to_coro (prev, "Coro::schedule", "current coroutine"),
852 sv_to_coro (next, "Coro::schedule", "next coroutine"),
853 TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK);
854 SvREFCNT_dec (next);
855 SvREFCNT_dec (prev);
856}
337 857
338MODULE = Coro::State PACKAGE = Coro::State 858MODULE = Coro::State PACKAGE = Coro::State
339 859
340PROTOTYPES: ENABLE 860PROTOTYPES: ENABLE
341 861
342BOOT: 862BOOT:
863{ /* {} necessary for stoopid perl-5.6.x */
864 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
865 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
866 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
867
868 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
869 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
870 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
871 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
872
343 if (!padlist_cache) 873 if (!padlist_cache)
344 padlist_cache = newHV (); 874 padlist_cache = newHV ();
875
876 main_mainstack = PL_mainstack;
877
878 {
879 SV *sv = perl_get_sv("Coro::API", 1);
880
881 coroapi.ver = CORO_API_VERSION - 1;
882 coroapi.transfer = api_transfer;
883 coroapi.schedule = api_schedule;
884 coroapi.ready = api_ready;
885 coroapi.nready = &coro_nready;
886
887 GCoroAPI = &coroapi;
888 sv_setiv(sv, (IV)&coroapi);
889 SvREADONLY_on(sv);
890 }
891}
345 892
346Coro::State 893Coro::State
347_newprocess(args) 894_newprocess(args)
348 SV * args 895 SV * args
349 PROTOTYPE: $ 896 PROTOTYPE: $
350 CODE: 897 CODE:
351 Coro__State coro; 898 Coro__State coro;
352 899
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 900 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref"); 901 croak ("Coro::State::_newprocess expects an arrayref");
355 902
356 New (0, coro, 1, struct coro); 903 New (0, coro, 1, struct coro);
357 904
905 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358 coro->mainstack = 0; /* actual work is done inside transfer */ 906 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 907 coro->stack = 0;
360 908
361 RETVAL = coro; 909 RETVAL = coro;
362 OUTPUT: 910 OUTPUT:
363 RETVAL 911 RETVAL
364 912
365void 913void
366transfer(prev,next) 914transfer(prev, next, flags)
367 Coro::State_or_hashref prev 915 Coro::State_or_hashref prev
368 Coro::State_or_hashref next 916 Coro::State_or_hashref next
917 int flags
918 PROTOTYPE: @
369 CODE: 919 CODE:
370
371 if (prev != next)
372 {
373 PUTBACK; 920 PUTBACK;
374 SAVE (aTHX_ prev); 921 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; 922 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 923
421void 924void
422DESTROY(coro) 925DESTROY(coro)
423 Coro::State coro 926 Coro::State coro
424 CODE: 927 CODE:
425 928
426 if (coro->mainstack) 929 if (coro->mainstack && coro->mainstack != main_mainstack)
427 { 930 {
428 struct coro temp; 931 struct coro temp;
429 932
430 PUTBACK;
431 SAVE(aTHX_ (&temp)); 933 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432 LOAD(aTHX_ coro); 934 LOAD(aTHX_ coro);
433 935
434 S_nuke_stacks (); 936 destroy_stacks (aTHX);
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436 937
437 LOAD((&temp)); 938 LOAD((&temp)); /* this will get rid of defsv etc.. */
438 SPAGAIN; 939
940 coro->mainstack = 0;
439 } 941 }
440 942
441 SvREFCNT_dec (coro->args); 943 deallocate_stack (coro);
944
442 Safefree (coro); 945 Safefree (coro);
443 946
947void
948flush()
949 CODE:
950#ifdef MAY_FLUSH
951 flush_padlist_cache ();
952#endif
444 953
954void
955_exit(code)
956 int code
957 PROTOTYPE: $
958 CODE:
959#if defined(__GLIBC__) || _POSIX_C_SOURCE
960 _exit (code);
961#else
962 signal (SIGTERM, SIG_DFL);
963 raise (SIGTERM);
964 exit (code);
965#endif
966
967MODULE = Coro::State PACKAGE = Coro::Cont
968
969# this is slightly dirty (should expose a c-level api)
970
971void
972yield(...)
973 PROTOTYPE: @
974 CODE:
975 static SV *returnstk;
976 SV *sv;
977 AV *defav = GvAV (PL_defgv);
978 struct coro *prev, *next;
979
980 if (!returnstk)
981 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
982
983 /* set up @_ -- ugly */
984 av_clear (defav);
985 av_fill (defav, items - 1);
986 while (items--)
987 av_store (defav, items, SvREFCNT_inc (ST(items)));
988
989 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
990 sv = av_pop ((AV *)SvRV (returnstk));
991 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
992 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
993 SvREFCNT_dec (sv);
994
995 transfer(aTHX_ prev, next, 0);
996
997MODULE = Coro::State PACKAGE = Coro
998
999# this is slightly dirty (should expose a c-level api)
1000
1001BOOT:
1002{
1003 int i;
1004 HV *stash = gv_stashpv ("Coro", TRUE);
1005
1006 newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
1007 newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1008 newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1009 newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
1010 newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1011 newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
1012
1013 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1014 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1015
1016 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1017 coro_ready[i] = newAV ();
1018}
1019
1020void
1021ready(self)
1022 SV * self
1023 CODE:
1024 api_ready (self);
1025
1026int
1027nready(...)
1028 PROTOTYPE:
1029 CODE:
1030 RETVAL = coro_nready;
1031 OUTPUT:
1032 RETVAL
1033
1034void
1035schedule(...)
1036 PROTOTYPE:
1037 ALIAS:
1038 cede = 1
1039 CODE:
1040 api_schedule (ix);
1041

Diff Legend

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