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.20 by root, Fri Aug 3 12:51:56 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
15# else
16# undef HAVE_MMAP
17# endif
18# endif
19#endif
20
21#define MAY_FLUSH /* increases codesize */
22
23/* perl-related */
24#define TRANSFER_SAVE_DEFAV 0x00000001
25#define TRANSFER_SAVE_DEFSV 0x00000002
26#define TRANSFER_SAVE_ERRSV 0x00000004
27/* c-related */
28#define TRANSFER_SAVE_CCTXT 0x00000008
29#ifdef CORO_LAZY_STACK
30# define TRANSFER_LAZY_STACK 0x00000010
7#else 31#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 32# define TRANSFER_LAZY_STACK 0x00000000
9#endif 33#endif
34
35#define TRANSFER_SAVE_ALL (TRANSFER_SAVE_DEFAV|TRANSFER_SAVE_DEFSV \
36 |TRANSFER_SAVE_ERRSV|TRANSFER_SAVE_CCTXT)
37
38#define SUB_INIT "Coro::State::initialize"
39#define UCORO_STATE "_coro_state"
40
41/* The next macro should delcare a variable stacklevel that contains and approximation
42 * to the current C stack pointer. It's property is that it changes with each call
43 * and should be unique. */
44#define dSTACKLEVEL void *stacklevel = &stacklevel
45
46#define labs(l) ((l) >= 0 ? (l) : -(l))
47
48/* this is actually not only the c stack but also c registers etc... */
49typedef struct {
50 int refcnt; /* pointer reference counter */
51 int usecnt; /* shared by how many coroutines */
52 int gencnt; /* generation counter */
53
54 coro_context cctx;
55
56 void *sptr;
57 long ssize; /* positive == mmap, otherwise malloc */
58} coro_stack;
10 59
11struct coro { 60struct coro {
61 /* the optional C context */
62 coro_stack *stack;
63 void *cursp;
64 int gencnt;
65
66 /* optionally saved, might be zero */
67 AV *defav;
68 SV *defsv;
69 SV *errsv;
70
71 /* saved global state not related to stacks */
12 U8 dowarn; 72 U8 dowarn;
13 AV *defav; 73 I32 in_eval;
14 74
75 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 76 PERL_SI *curstackinfo;
16 AV *curstack; 77 AV *curstack;
17 AV *mainstack; 78 AV *mainstack;
18 SV **stack_sp; 79 SV **stack_sp;
19 OP *op; 80 OP *op;
… …
35 I32 savestack_max; 96 I32 savestack_max;
36 OP **retstack; 97 OP **retstack;
37 I32 retstack_ix; 98 I32 retstack_ix;
38 I32 retstack_max; 99 I32 retstack_max;
39 COP *curcop; 100 COP *curcop;
101 JMPENV *top_env;
40 102
103 /* data associated with this coroutine (initial args) */
41 AV *args; 104 AV *args;
42}; 105};
43 106
44typedef struct coro *Coro__State; 107typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 108typedef struct coro *Coro__State_or_hashref;
46 109
110static AV *main_mainstack; /* used to differentiate between $main and others */
111static HV *coro_state_stash;
112static SV *ucoro_state_sv;
113static U32 ucoro_state_hash;
47static HV *padlist_cache; 114static HV *padlist_cache;
48 115
49/* mostly copied from op.c:cv_clone2 */ 116/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 117STATIC AV *
51clone_padlist (AV *protopadlist) 118clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 182 SvPADTMP_on (sv);
116 npad[ix] = sv; 183 npad[ix] = sv;
117 } 184 }
118 } 185 }
119 186
120#if 0 /* NONOTUNDERSTOOD */ 187#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 188 /* Now that vars are all in place, clone nested closures. */
122 189
123 for (ix = fpad; ix > 0; ix--) { 190 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 191 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 192 if (namesv
… …
138#endif 205#endif
139 206
140 return newpadlist; 207 return newpadlist;
141} 208}
142 209
210#ifdef MAY_FLUSH
143STATIC AV * 211STATIC AV *
144free_padlist (AV *padlist) 212free_padlist (AV *padlist)
145{ 213{
146 /* may be during global destruction */ 214 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 215 if (SvREFCNT(padlist))
… …
156 } 224 }
157 225
158 SvREFCNT_dec((SV*)padlist); 226 SvREFCNT_dec((SV*)padlist);
159 } 227 }
160} 228}
229#endif
161 230
162STATIC AV * 231/* the next two functions merely cache the padlists */
163unuse_padlist (AV *padlist) 232STATIC void
233get_padlist (CV *cv)
164{ 234{
235 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
236
237 if (he && AvFILLp ((AV *)*he) >= 0)
238 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
239 else
240 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
241}
242
243STATIC void
244put_padlist (CV *cv)
245{
246 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
247
248 if (SvTYPE (*he) != SVt_PVAV)
249 {
250 SvREFCNT_dec (*he);
251 *he = (SV *)newAV ();
252 }
253
254 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
255}
256
257#ifdef MAY_FLUSH
258STATIC void
259flush_padlist_cache ()
260{
261 HV *hv = padlist_cache;
262 padlist_cache = newHV ();
263
264 if (hv_iterinit (hv))
265 {
266 HE *he;
267 AV *padlist;
268
269 while (!!(he = hv_iternext (hv)))
270 {
271 AV *av = (AV *)HeVAL(he);
272
273 /* casting is fun. */
274 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
165 free_padlist (padlist); 275 free_padlist (padlist);
276 }
277 }
278
279 SvREFCNT_dec (hv);
166} 280}
281#endif
282
283#define SB do {
284#define SE } while (0)
285
286#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
287#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
288
289#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
167 290
168static void 291static void
169SAVE(pTHX_ Coro__State c) 292load_state(pTHX_ Coro__State c)
293{
294 PL_dowarn = c->dowarn;
295 PL_in_eval = c->in_eval;
296
297 PL_curstackinfo = c->curstackinfo;
298 PL_curstack = c->curstack;
299 PL_mainstack = c->mainstack;
300 PL_stack_sp = c->stack_sp;
301 PL_op = c->op;
302 PL_curpad = c->curpad;
303 PL_stack_base = c->stack_base;
304 PL_stack_max = c->stack_max;
305 PL_tmps_stack = c->tmps_stack;
306 PL_tmps_floor = c->tmps_floor;
307 PL_tmps_ix = c->tmps_ix;
308 PL_tmps_max = c->tmps_max;
309 PL_markstack = c->markstack;
310 PL_markstack_ptr = c->markstack_ptr;
311 PL_markstack_max = c->markstack_max;
312 PL_scopestack = c->scopestack;
313 PL_scopestack_ix = c->scopestack_ix;
314 PL_scopestack_max = c->scopestack_max;
315 PL_savestack = c->savestack;
316 PL_savestack_ix = c->savestack_ix;
317 PL_savestack_max = c->savestack_max;
318 PL_retstack = c->retstack;
319 PL_retstack_ix = c->retstack_ix;
320 PL_retstack_max = c->retstack_max;
321 PL_curcop = c->curcop;
322 PL_top_env = c->top_env;
323
324 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
325 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
326 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
327
328 {
329 dSP;
330 CV *cv;
331
332 /* now do the ugly restore mess */
333 while ((cv = (CV *)POPs))
334 {
335 AV *padlist = (AV *)POPs;
336
337 if (padlist)
338 {
339 put_padlist (cv); /* mark this padlist as available */
340 CvPADLIST(cv) = padlist;
341#ifdef USE_THREADS
342 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
343#endif
344 }
345
346 ++CvDEPTH(cv);
347 }
348
349 PUTBACK;
350 }
351}
352
353static void
354save_state(pTHX_ Coro__State c, int flags)
170{ 355{
171 { 356 {
172 dSP; 357 dSP;
173 I32 cxix = cxstack_ix; 358 I32 cxix = cxstack_ix;
359 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 360 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 361
177 /* 362 /*
178 * the worst thing you can imagine happens first - we have to save 363 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 364 * (and reinitialize) all cv's in the whole callchain :(
180 */ 365 */
181 366
182 PUSHs (Nullsv); 367 PUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 368 /* this loop was inspired by pp_caller */
184 for (;;) 369 for (;;)
185 { 370 {
186 while (cxix >= 0) 371 do
187 { 372 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 373 PERL_CONTEXT *cx = &ccstk[cxix--];
189 374
190 if (CxTYPE(cx) == CXt_SUB) 375 if (CxTYPE(cx) == CXt_SUB)
191 { 376 {
192 CV *cv = cx->blk_sub.cv; 377 CV *cv = cx->blk_sub.cv;
193 if (CvDEPTH(cv)) 378 if (CvDEPTH(cv))
194 { 379 {
195#ifdef USE_THREADS 380#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv)); 381 /*XPUSHs ((SV *)CvOWNER(cv));*/
382 /*CvOWNER(cv) = 0;*/
383 /*error must unlock this cv etc.. etc...*/
197#endif 384#endif
198 EXTEND (SP, 3); 385 EXTEND (SP, CvDEPTH(cv)*2);
386
387 while (--CvDEPTH(cv))
388 {
389 /* this tells the restore code to increment CvDEPTH */
390 PUSHs (Nullsv);
199 PUSHs ((SV *)CvDEPTH(cv)); 391 PUSHs ((SV *)cv);
392 }
393
200 PUSHs ((SV *)CvPADLIST(cv)); 394 PUSHs ((SV *)CvPADLIST(cv));
201 PUSHs ((SV *)cv); 395 PUSHs ((SV *)cv);
202 396
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv)); 397 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 } 398 }
213 } 399 }
214 else if (CxTYPE(cx) == CXt_FORMAT) 400 else if (CxTYPE(cx) == CXt_FORMAT)
215 { 401 {
216 /* I never used formats, so how should I know how these are implemented? */ 402 /* I never used formats, so how should I know how these are implemented? */
217 /* my bold guess is as a simple, plain sub... */ 403 /* my bold guess is as a simple, plain sub... */
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 404 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219 } 405 }
220 } 406 }
407 while (cxix >= 0);
221 408
222 if (top_si->si_type == PERLSI_MAIN) 409 if (top_si->si_type == PERLSI_MAIN)
223 break; 410 break;
224 411
225 top_si = top_si->si_prev; 412 top_si = top_si->si_prev;
… …
228 } 415 }
229 416
230 PUTBACK; 417 PUTBACK;
231 } 418 }
232 419
420 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
421 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
422 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
423
424 /* I have not the slightest idea of why av_reify is necessary */
425 /* but if it's missing the defav contents magically get replaced sometimes */
426 if (c->defav)
427 av_reify (c->defav);
428
233 c->dowarn = PL_dowarn; 429 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 430 c->in_eval = PL_in_eval;
431
235 c->curstackinfo = PL_curstackinfo; 432 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack; 433 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack; 434 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp; 435 c->stack_sp = PL_stack_sp;
239 c->op = PL_op; 436 c->op = PL_op;
… …
255 c->savestack_max = PL_savestack_max; 452 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack; 453 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix; 454 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max; 455 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop; 456 c->curcop = PL_curcop;
457 c->top_env = PL_top_env;
458}
459
460/*
461 * allocate various perl stacks. This is an exact copy
462 * of perl.c:init_stacks, except that it uses less memory
463 * on the assumption that coroutines do not usually need
464 * a lot of stackspace.
465 */
466STATIC void
467coro_init_stacks (pTHX)
468{
469 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
470 PL_curstackinfo->si_type = PERLSI_MAIN;
471 PL_curstack = PL_curstackinfo->si_stack;
472 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
473
474 PL_stack_base = AvARRAY(PL_curstack);
475 PL_stack_sp = PL_stack_base;
476 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
477
478 New(50,PL_tmps_stack,96,SV*);
479 PL_tmps_floor = -1;
480 PL_tmps_ix = -1;
481 PL_tmps_max = 96;
482
483 New(54,PL_markstack,16,I32);
484 PL_markstack_ptr = PL_markstack;
485 PL_markstack_max = PL_markstack + 16;
486
487 SET_MARK_OFFSET;
488
489 New(54,PL_scopestack,16,I32);
490 PL_scopestack_ix = 0;
491 PL_scopestack_max = 16;
492
493 New(54,PL_savestack,96,ANY);
494 PL_savestack_ix = 0;
495 PL_savestack_max = 96;
496
497 New(54,PL_retstack,8,OP*);
498 PL_retstack_ix = 0;
499 PL_retstack_max = 8;
500}
501
502/*
503 * destroy the stacks, the callchain etc...
504 * still there is a memleak of 128 bytes...
505 */
506STATIC void
507destroy_stacks(pTHX)
508{
509 /* is this ugly, I ask? */
510 while (PL_scopestack_ix)
511 LEAVE;
512
513 /* sure it is, but more important: is it correct?? :/ */
514 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
515 FREETMPS;
516
517 while (PL_curstackinfo->si_next)
518 PL_curstackinfo = PL_curstackinfo->si_next;
519
520 while (PL_curstackinfo)
521 {
522 PERL_SI *p = PL_curstackinfo->si_prev;
523
524 {
525 dSP;
526 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
527 PUTBACK; /* possibly superfluous */
528 }
529
530 dounwind(-1);
531
532 SvREFCNT_dec(PL_curstackinfo->si_stack);
533 Safefree(PL_curstackinfo->si_cxstack);
534 Safefree(PL_curstackinfo);
535 PL_curstackinfo = p;
536 }
537
538 Safefree(PL_tmps_stack);
539 Safefree(PL_markstack);
540 Safefree(PL_scopestack);
541 Safefree(PL_savestack);
542 Safefree(PL_retstack);
260} 543}
261 544
262static void 545static void
263LOAD(pTHX_ Coro__State c) 546allocate_stack (Coro__State ctx, int alloc)
264{ 547{
265 PL_dowarn = c->dowarn; 548 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 549
550 New (0, stack, 1, coro_stack);
551
552 stack->refcnt = 1;
553 stack->usecnt = 1;
554 stack->gencnt = ctx->gencnt = 0;
555 if (alloc)
293 { 556 {
294 dSP; 557#ifdef HAVE_MMAP
295 CV *cv; 558 stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
296 559 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
297 /* now do the ugly restore mess */ 560 if (stack->sptr == (void *)-1)
298 while ((cv = (CV *)POPs)) 561#endif
299 { 562 {
300 AV *padlist = (AV *)POPs; 563 /*FIXME*//*D*//* reasonable stack size! */
301 564 stack->ssize = -4096 * sizeof (long);
302 unuse_padlist (CvPADLIST(cv)); 565 New (0, stack->sptr, 4096, long);
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 } 566 }
567 }
568 else
569 stack->sptr = 0;
311 570
571 ctx->stack = stack;
572}
573
574static void
575deallocate_stack (Coro__State ctx)
576{
577 coro_stack *stack = ctx->stack;
578
579 ctx->stack = 0;
580
581 if (stack)
582 {
583 if (!--stack->refcnt)
584 {
585#ifdef HAVE_MMAP
586 if (stack->ssize > 0 && stack->sptr)
587 munmap (stack->sptr, stack->ssize);
588 else
589#else
590 Safefree (stack->sptr);
591#endif
592 Safefree (stack);
593 }
594 else if (ctx->gencnt == stack->gencnt)
595 --stack->usecnt;
596 }
597}
598
599static void
600setup_coro (void *arg)
601{
602 /*
603 * emulate part of the perl startup here.
604 */
605 dSP;
606 Coro__State ctx = (Coro__State)arg;
607 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
608
609 coro_init_stacks (aTHX);
610 /*PL_curcop = 0;*/
611 /*PL_in_eval = PL_in_eval;*/ /* inherit */
612 SvREFCNT_dec (GvAV (PL_defgv));
613 GvAV (PL_defgv) = ctx->args;
614
615 SPAGAIN;
616
617 if (ctx->stack)
618 {
619 ctx->cursp = 0;
620
621 PUSHMARK(SP);
312 PUTBACK; 622 PUTBACK;
623 (void) call_sv (sub_init, G_VOID|G_NOARGS|G_EVAL);
624
625 if (SvTRUE (ERRSV))
626 croak (NULL);
627 else
628 croak ("FATAL: CCTXT coroutine returned!");
313 } 629 }
314} 630 else
631 {
632 UNOP myop;
315 633
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 634 PL_op = (OP *)&myop;
635
636 Zero(&myop, 1, UNOP);
637 myop.op_next = Nullop;
638 myop.op_flags = OPf_WANT_VOID;
639
640 PUSHMARK(SP);
641 XPUSHs (sub_init);
642 /*
643 * the next line is slightly wrong, as PL_op->op_next
644 * is actually being executed so we skip the first op.
645 * that doesn't matter, though, since it is only
646 * pp_nextstate and we never return...
647 * ah yes, and I don't care anyways ;)
648 */
649 PUTBACK;
650 PL_op = pp_entersub();
651 SPAGAIN;
652
653 ENTER; /* necessary e.g. for dounwind */
654 }
655}
656
657static void
658continue_coro (void *arg)
659{
660 /*
661 * this is a _very_ stripped down perl interpreter ;)
662 */
663 Coro__State ctx = (Coro__State)arg;
664
665 /*FIXME*//* must set up top_env here */
666 ctx->cursp = 0;
667 PL_op = PL_op->op_next;
668 CALLRUNOPS(aTHX);
669
670 abort ();
671}
672
317STATIC void 673STATIC void
318S_nuke_stacks(pTHX) 674transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
319{ 675{
320 while (PL_curstackinfo->si_next) 676 dSP;
321 PL_curstackinfo = PL_curstackinfo->si_next; 677 dSTACKLEVEL;
322 while (PL_curstackinfo) { 678
323 PERL_SI *p = PL_curstackinfo->si_prev; 679 if (prev != next)
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 680 {
325 Safefree(PL_curstackinfo->si_cxstack); 681 if (next->mainstack)
326 Safefree(PL_curstackinfo); 682 {
327 PL_curstackinfo = p; 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 }
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 }
744 }
745 else
746 setup_coro (next);
747 }
328 } 748 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335 749
336#define SUB_INIT "Coro::State::_newcoro" 750 next->cursp = stacklevel;
751}
337 752
338MODULE = Coro::State PACKAGE = Coro::State 753MODULE = Coro::State PACKAGE = Coro::State
339 754
340PROTOTYPES: ENABLE 755PROTOTYPES: ENABLE
341 756
342BOOT: 757BOOT:
758{ /* {} necessary for stoopid perl-5.6.x */
759 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
760 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
761 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
762
763 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
764 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
765 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
766 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
767
343 if (!padlist_cache) 768 if (!padlist_cache)
344 padlist_cache = newHV (); 769 padlist_cache = newHV ();
770
771 main_mainstack = PL_mainstack;
772}
345 773
346Coro::State 774Coro::State
347_newprocess(args) 775_newprocess(args)
348 SV * args 776 SV * args
349 PROTOTYPE: $ 777 PROTOTYPE: $
350 CODE: 778 CODE:
351 Coro__State coro; 779 Coro__State coro;
352 780
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 781 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref"); 782 croak ("Coro::State::_newprocess expects an arrayref");
355 783
356 New (0, coro, 1, struct coro); 784 New (0, coro, 1, struct coro);
357 785
786 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358 coro->mainstack = 0; /* actual work is done inside transfer */ 787 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 788 coro->stack = 0;
360 789
361 RETVAL = coro; 790 RETVAL = coro;
362 OUTPUT: 791 OUTPUT:
363 RETVAL 792 RETVAL
364 793
365void 794void
366transfer(prev,next) 795transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
367 Coro::State_or_hashref prev 796 Coro::State_or_hashref prev
368 Coro::State_or_hashref next 797 Coro::State_or_hashref next
798 int flags
799 PROTOTYPE: @
369 CODE: 800 CODE:
370
371 if (prev != next)
372 {
373 PUTBACK; 801 PUTBACK;
374 SAVE (aTHX_ prev); 802 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; 803 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 804
421void 805void
422DESTROY(coro) 806DESTROY(coro)
423 Coro::State coro 807 Coro::State coro
424 CODE: 808 CODE:
425 809
426 if (coro->mainstack) 810 if (coro->mainstack && coro->mainstack != main_mainstack)
427 { 811 {
428 struct coro temp; 812 struct coro temp;
429 813
430 PUTBACK;
431 SAVE(aTHX_ (&temp)); 814 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432 LOAD(aTHX_ coro); 815 LOAD(aTHX_ coro);
433 816
434 S_nuke_stacks (); 817 destroy_stacks (aTHX);
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436 818
437 LOAD((&temp)); 819 LOAD((&temp)); /* this will get rid of defsv etc.. */
438 SPAGAIN; 820
821 coro->mainstack = 0;
439 } 822 }
440 823
441 SvREFCNT_dec (coro->args); 824 deallocate_stack (coro);
825
442 Safefree (coro); 826 Safefree (coro);
443 827
828void
829flush()
830 CODE:
831#ifdef MAY_FLUSH
832 flush_padlist_cache ();
833#endif
444 834
835void
836_exit(code)
837 int code
838 PROTOTYPE: $
839 CODE:
840#if defined(__GLIBC__) || _POSIX_C_SOURCE
841 _exit (code);
842#else
843 signal (SIGTERM, SIG_DFL);
844 raise (SIGTERM);
845 exit (code);
846#endif
847
848MODULE = Coro::State PACKAGE = Coro::Cont
849
850# this is slightly dirty
851
852void
853yield(...)
854 PROTOTYPE: @
855 CODE:
856 static SV *returnstk;
857 SV *sv;
858 AV *defav = GvAV (PL_defgv);
859 struct coro *prev, *next;
860
861 if (!returnstk)
862 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
863
864 /* set up @_ -- ugly */
865 av_clear (defav);
866 av_fill (defav, items - 1);
867 while (items--)
868 av_store (defav, items, SvREFCNT_inc (ST(items)));
869
870 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
871 sv = av_pop ((AV *)SvRV (returnstk));
872 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
873 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
874 SvREFCNT_dec (sv);
875
876 transfer(aTHX_ prev, next, 0);
877

Diff Legend

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