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

Diff Legend

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