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.1 by root, Sat Jul 14 22:14:21 2001 UTC vs.
Revision 1.18 by root, Thu Jul 26 03:46:15 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#include "libcoro/coro.c"
6
7#ifdef HAVE_MMAP
8# include <unistd.h>
9# include <sys/mman.h>
10# ifndef MAP_ANON
11# ifdef MAP_ANONYMOUS
12# define MAP_ANON MAP_ANONYMOUS
13# else
14# undef HAVE_MMAP
15# endif
16# endif
17#endif
18
19#define MAY_FLUSH /* increases codesize */
20
21/* perl-related */
22#define TRANSFER_SAVE_DEFAV 0x00000001
23#define TRANSFER_SAVE_DEFSV 0x00000002
24#define TRANSFER_SAVE_ERRSV 0x00000004
25/* c-related */
26#define TRANSFER_SAVE_CCTXT 0x00000008
27#ifdef CORO_LAZY_STACK
28# define TRANSFER_LAZY_STACK 0x00000010
29#else
30# define TRANSFER_LAZY_STACK 0x00000000
31#endif
32
33#define TRANSFER_SAVE_ALL (TRANSFER_SAVE_DEFAV|TRANSFER_SAVE_DEFSV \
34 |TRANSFER_SAVE_ERRSV|TRANSFER_SAVE_CCTXT)
35
36#define SUB_INIT "Coro::State::initialize"
37#define UCORO_STATE "_coro_state"
38
39/* The next macro should delcare a variable stacklevel that contains and approximation
40 * to the current C stack pointer. It's property is that it changes with each call
41 * and should be unique. */
42#define dSTACKLEVEL void *stacklevel = &stacklevel
43
44#define labs(l) ((l) >= 0 ? (l) : -(l))
45
46/* this is actually not only the c stack but also c registers etc... */
47typedef struct {
48 int refcnt; /* pointer reference counter */
49 int usecnt; /* shared by how many coroutines */
50 int gencnt; /* generation counter */
51
52 coro_context cctx;
53
54 void *sptr;
55 long ssize; /* positive == mmap, otherwise malloc */
56} coro_stack;
57
5struct coro { 58struct coro {
59 /* the optional C context */
60 coro_stack *stack;
61 void *cursp;
62 int gencnt;
63
64 /* optionally saved, might be zero */
65 AV *defav;
66 SV *defsv;
67 SV *errsv;
68
69 /* saved global state not related to stacks */
6 U8 dowarn; 70 U8 dowarn;
7 71
72 /* the stacks and related info (callchain etc..) */
8 PERL_SI *curstackinfo; 73 PERL_SI *curstackinfo;
9 AV *curstack; 74 AV *curstack;
10 AV *mainstack; 75 AV *mainstack;
11 SV **stack_sp; 76 SV **stack_sp;
12 OP *op; 77 OP *op;
… …
28 I32 savestack_max; 93 I32 savestack_max;
29 OP **retstack; 94 OP **retstack;
30 I32 retstack_ix; 95 I32 retstack_ix;
31 I32 retstack_max; 96 I32 retstack_max;
32 COP *curcop; 97 COP *curcop;
98 JMPENV start_env;
99 JMPENV *top_env;
33 100
34 SV *proc; 101 /* data associated with this coroutine (initial args) */
102 AV *args;
35}; 103};
36 104
37typedef struct coro *Coro__State; 105typedef struct coro *Coro__State;
38typedef struct coro *Coro__State_or_hashref; 106typedef struct coro *Coro__State_or_hashref;
39 107
40#define SAVE(c) \ 108static AV *main_mainstack; /* used to differentiate between $main and others */
109static HV *coro_state_stash;
110static SV *ucoro_state_sv;
111static U32 ucoro_state_hash;
112static HV *padlist_cache;
113
114/* mostly copied from op.c:cv_clone2 */
115STATIC AV *
116clone_padlist (AV *protopadlist)
117{
118 AV *av;
119 I32 ix;
120 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
121 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
122 SV **pname = AvARRAY (protopad_name);
123 SV **ppad = AvARRAY (protopad);
124 I32 fname = AvFILLp (protopad_name);
125 I32 fpad = AvFILLp (protopad);
126 AV *newpadlist, *newpad_name, *newpad;
127 SV **npad;
128
129 newpad_name = newAV ();
130 for (ix = fname; ix >= 0; ix--)
131 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
132
133 newpad = newAV ();
134 av_fill (newpad, AvFILLp (protopad));
135 npad = AvARRAY (newpad);
136
137 newpadlist = newAV ();
138 AvREAL_off (newpadlist);
139 av_store (newpadlist, 0, (SV *) newpad_name);
140 av_store (newpadlist, 1, (SV *) newpad);
141
142 av = newAV (); /* will be @_ */
143 av_extend (av, 0);
144 av_store (newpad, 0, (SV *) av);
145 AvFLAGS (av) = AVf_REIFY;
146
147 for (ix = fpad; ix > 0; ix--)
148 {
149 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
150 if (namesv && namesv != &PL_sv_undef)
151 {
152 char *name = SvPVX (namesv); /* XXX */
153 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')
154 { /* lexical from outside? */
155 npad[ix] = SvREFCNT_inc (ppad[ix]);
156 }
157 else
158 { /* our own lexical */
159 SV *sv;
160 if (*name == '&')
161 sv = SvREFCNT_inc (ppad[ix]);
162 else if (*name == '@')
163 sv = (SV *) newAV ();
164 else if (*name == '%')
165 sv = (SV *) newHV ();
166 else
167 sv = NEWSV (0, 0);
168 if (!SvPADBUSY (sv))
169 SvPADMY_on (sv);
170 npad[ix] = sv;
171 }
172 }
173 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
174 {
175 npad[ix] = SvREFCNT_inc (ppad[ix]);
176 }
177 else
178 {
179 SV *sv = NEWSV (0, 0);
180 SvPADTMP_on (sv);
181 npad[ix] = sv;
182 }
183 }
184
185#if 0 /* return -ENOTUNDERSTOOD */
186 /* Now that vars are all in place, clone nested closures. */
187
188 for (ix = fpad; ix > 0; ix--) {
189 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
190 if (namesv
191 && namesv != &PL_sv_undef
192 && !(SvFLAGS(namesv) & SVf_FAKE)
193 && *SvPVX(namesv) == '&'
194 && CvCLONE(ppad[ix]))
195 {
196 CV *kid = cv_clone((CV*)ppad[ix]);
197 SvREFCNT_dec(ppad[ix]);
198 CvCLONE_on(kid);
199 SvPADMY_on(kid);
200 npad[ix] = (SV*)kid;
201 }
202 }
203#endif
204
205 return newpadlist;
206}
207
208#ifdef MAY_FLUSH
209STATIC AV *
210free_padlist (AV *padlist)
211{
212 /* may be during global destruction */
213 if (SvREFCNT(padlist))
214 {
215 I32 i = AvFILLp(padlist);
216 while (i >= 0)
217 {
218 SV **svp = av_fetch(padlist, i--, FALSE);
219 SV *sv = svp ? *svp : Nullsv;
220 if (sv)
221 SvREFCNT_dec(sv);
222 }
223
224 SvREFCNT_dec((SV*)padlist);
225 }
226}
227#endif
228
229/* the next two functions merely cache the padlists */
230STATIC void
231get_padlist (CV *cv)
232{
233 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
234
235 if (he && AvFILLp ((AV *)*he) >= 0)
236 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
237 else
238 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
239}
240
241STATIC void
242put_padlist (CV *cv)
243{
244 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
245
246 if (SvTYPE (*he) != SVt_PVAV)
247 {
248 SvREFCNT_dec (*he);
249 *he = (SV *)newAV ();
250 }
251
252 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
253}
254
255#ifdef MAY_FLUSH
256STATIC void
257flush_padlist_cache ()
258{
259 HV *hv = padlist_cache;
260 padlist_cache = newHV ();
261
262 if (hv_iterinit (hv))
263 {
264 HE *he;
265 AV *padlist;
266
267 while (!!(he = hv_iternext (hv)))
268 {
269 AV *av = (AV *)HeVAL(he);
270
271 /* casting is fun. */
272 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
273 free_padlist (padlist);
274 }
275 }
276
277 SvREFCNT_dec (hv);
278}
279#endif
280
281#define SB do {
282#define SE } while (0)
283
284#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
285#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
286
287#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
288
289static void
290load_state(pTHX_ Coro__State c)
291{
292 PL_dowarn = c->dowarn;
293
294 PL_curstackinfo = c->curstackinfo;
295 PL_curstack = c->curstack;
296 PL_mainstack = c->mainstack;
297 PL_stack_sp = c->stack_sp;
298 PL_op = c->op;
299 PL_curpad = c->curpad;
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_start_env = c->start_env;
320 PL_top_env = c->top_env;
321
322 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
323 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
324 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
325
326 {
327 dSP;
328 CV *cv;
329
330 /* now do the ugly restore mess */
331 while ((cv = (CV *)POPs))
332 {
333 AV *padlist = (AV *)POPs;
334
335 if (padlist)
336 {
337 put_padlist (cv); /* mark this padlist as available */
338 CvPADLIST(cv) = padlist;
339#ifdef USE_THREADS
340 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
341#endif
342 }
343
344 ++CvDEPTH(cv);
345 }
346
347 PUTBACK;
348 }
349}
350
351static void
352save_state(pTHX_ Coro__State c, int flags)
353{
354 {
355 dSP;
356 I32 cxix = cxstack_ix;
357 PERL_CONTEXT *ccstk = cxstack;
358 PERL_SI *top_si = PL_curstackinfo;
359
360 /*
361 * the worst thing you can imagine happens first - we have to save
362 * (and reinitialize) all cv's in the whole callchain :(
363 */
364
365 PUSHs (Nullsv);
366 /* this loop was inspired by pp_caller */
367 for (;;)
368 {
369 do
370 {
371 PERL_CONTEXT *cx = &ccstk[cxix--];
372
373 if (CxTYPE(cx) == CXt_SUB)
374 {
375 CV *cv = cx->blk_sub.cv;
376 if (CvDEPTH(cv))
377 {
378#ifdef USE_THREADS
379 /*XPUSHs ((SV *)CvOWNER(cv));*/
380 /*CvOWNER(cv) = 0;*/
381 /*error must unlock this cv etc.. etc...*/
382#endif
383 EXTEND (SP, CvDEPTH(cv)*2);
384
385 while (--CvDEPTH(cv))
386 {
387 /* this tells the restore code to increment CvDEPTH */
388 PUSHs (Nullsv);
389 PUSHs ((SV *)cv);
390 }
391
392 PUSHs ((SV *)CvPADLIST(cv));
393 PUSHs ((SV *)cv);
394
395 get_padlist (cv); /* this is a monster */
396 }
397 }
398 else if (CxTYPE(cx) == CXt_FORMAT)
399 {
400 /* I never used formats, so how should I know how these are implemented? */
401 /* my bold guess is as a simple, plain sub... */
402 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
403 }
404 }
405 while (cxix >= 0);
406
407 if (top_si->si_type == PERLSI_MAIN)
408 break;
409
410 top_si = top_si->si_prev;
411 ccstk = top_si->si_cxstack;
412 cxix = top_si->si_cxix;
413 }
414
415 PUTBACK;
416 }
417
418 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
419 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
420 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
421
422 /* I have not the slightest idea of why av_reify is necessary */
423 /* but if it's missing the defav contents magically get replaced sometimes */
424 if (c->defav)
425 av_reify (c->defav);
426
41 c->dowarn = PL_dowarn; \ 427 c->dowarn = PL_dowarn;
428
42 c->curstackinfo = PL_curstackinfo; \ 429 c->curstackinfo = PL_curstackinfo;
43 c->curstack = PL_curstack; \ 430 c->curstack = PL_curstack;
44 c->mainstack = PL_mainstack; \ 431 c->mainstack = PL_mainstack;
45 c->stack_sp = PL_stack_sp; \ 432 c->stack_sp = PL_stack_sp;
46 c->op = PL_op; \ 433 c->op = PL_op;
47 c->curpad = PL_curpad; \ 434 c->curpad = PL_curpad;
48 c->stack_base = PL_stack_base; \ 435 c->stack_base = PL_stack_base;
49 c->stack_max = PL_stack_max; \ 436 c->stack_max = PL_stack_max;
50 c->tmps_stack = PL_tmps_stack; \ 437 c->tmps_stack = PL_tmps_stack;
51 c->tmps_floor = PL_tmps_floor; \ 438 c->tmps_floor = PL_tmps_floor;
52 c->tmps_ix = PL_tmps_ix; \ 439 c->tmps_ix = PL_tmps_ix;
53 c->tmps_max = PL_tmps_max; \ 440 c->tmps_max = PL_tmps_max;
54 c->markstack = PL_markstack; \ 441 c->markstack = PL_markstack;
55 c->markstack_ptr = PL_markstack_ptr; \ 442 c->markstack_ptr = PL_markstack_ptr;
56 c->markstack_max = PL_markstack_max; \ 443 c->markstack_max = PL_markstack_max;
57 c->scopestack = PL_scopestack; \ 444 c->scopestack = PL_scopestack;
58 c->scopestack_ix = PL_scopestack_ix; \ 445 c->scopestack_ix = PL_scopestack_ix;
59 c->scopestack_max = PL_scopestack_max;\ 446 c->scopestack_max = PL_scopestack_max;
60 c->savestack = PL_savestack; \ 447 c->savestack = PL_savestack;
61 c->savestack_ix = PL_savestack_ix; \ 448 c->savestack_ix = PL_savestack_ix;
62 c->savestack_max = PL_savestack_max; \ 449 c->savestack_max = PL_savestack_max;
63 c->retstack = PL_retstack; \ 450 c->retstack = PL_retstack;
64 c->retstack_ix = PL_retstack_ix; \ 451 c->retstack_ix = PL_retstack_ix;
65 c->retstack_max = PL_retstack_max; \ 452 c->retstack_max = PL_retstack_max;
66 c->curcop = PL_curcop; 453 c->curcop = PL_curcop;
454 c->start_env = PL_start_env;
455 c->top_env = PL_top_env;
456}
67 457
68#define LOAD(c) \ 458/*
69 PL_dowarn = c->dowarn; \ 459 * allocate various perl stacks. This is an exact copy
70 PL_curstackinfo = c->curstackinfo; \ 460 * of perl.c:init_stacks, except that it uses less memory
71 PL_curstack = c->curstack; \ 461 * on the assumption that coroutines do not usually need
72 PL_mainstack = c->mainstack; \ 462 * a lot of stackspace.
73 PL_stack_sp = c->stack_sp; \ 463 */
74 PL_op = c->op; \
75 PL_curpad = c->curpad; \
76 PL_stack_base = c->stack_base; \
77 PL_stack_max = c->stack_max; \
78 PL_tmps_stack = c->tmps_stack; \
79 PL_tmps_floor = c->tmps_floor; \
80 PL_tmps_ix = c->tmps_ix; \
81 PL_tmps_max = c->tmps_max; \
82 PL_markstack = c->markstack; \
83 PL_markstack_ptr = c->markstack_ptr; \
84 PL_markstack_max = c->markstack_max; \
85 PL_scopestack = c->scopestack; \
86 PL_scopestack_ix = c->scopestack_ix; \
87 PL_scopestack_max = c->scopestack_max;\
88 PL_savestack = c->savestack; \
89 PL_savestack_ix = c->savestack_ix; \
90 PL_savestack_max = c->savestack_max; \
91 PL_retstack = c->retstack; \
92 PL_retstack_ix = c->retstack_ix; \
93 PL_retstack_max = c->retstack_max; \
94 PL_curcop = c->curcop;
95
96/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
97STATIC void 464STATIC void
98S_nuke_stacks(pTHX) 465coro_init_stacks (pTHX)
99{ 466{
467 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
468 PL_curstackinfo->si_type = PERLSI_MAIN;
469 PL_curstack = PL_curstackinfo->si_stack;
470 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
471
472 PL_stack_base = AvARRAY(PL_curstack);
473 PL_stack_sp = PL_stack_base;
474 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
475
476 New(50,PL_tmps_stack,96,SV*);
477 PL_tmps_floor = -1;
478 PL_tmps_ix = -1;
479 PL_tmps_max = 96;
480
481 New(54,PL_markstack,16,I32);
482 PL_markstack_ptr = PL_markstack;
483 PL_markstack_max = PL_markstack + 16;
484
485 SET_MARK_OFFSET;
486
487 New(54,PL_scopestack,16,I32);
488 PL_scopestack_ix = 0;
489 PL_scopestack_max = 16;
490
491 New(54,PL_savestack,96,ANY);
492 PL_savestack_ix = 0;
493 PL_savestack_max = 96;
494
495 New(54,PL_retstack,8,OP*);
496 PL_retstack_ix = 0;
497 PL_retstack_max = 8;
498}
499
500/*
501 * destroy the stacks, the callchain etc...
502 * still there is a memleak of 128 bytes...
503 */
504STATIC void
505destroy_stacks(pTHX)
506{
507 /* is this ugly, I ask? */
508 while (PL_scopestack_ix)
509 LEAVE;
510
511 /* sure it is, but more important: is it correct?? :/ */
512 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
513 FREETMPS;
514
100 while (PL_curstackinfo->si_next) 515 while (PL_curstackinfo->si_next)
101 PL_curstackinfo = PL_curstackinfo->si_next; 516 PL_curstackinfo = PL_curstackinfo->si_next;
517
102 while (PL_curstackinfo) { 518 while (PL_curstackinfo)
519 {
103 PERL_SI *p = PL_curstackinfo->si_prev; 520 PERL_SI *p = PL_curstackinfo->si_prev;
104 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 521
522 {
523 dSP;
524 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
525 PUTBACK; /* possibly superfluous */
526 }
527
528 dounwind(-1);
529
530 SvREFCNT_dec(PL_curstackinfo->si_stack);
105 Safefree(PL_curstackinfo->si_cxstack); 531 Safefree(PL_curstackinfo->si_cxstack);
106 Safefree(PL_curstackinfo); 532 Safefree(PL_curstackinfo);
107 PL_curstackinfo = p; 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);
541}
542
543static void
544allocate_stack (Coro__State ctx, int alloc)
545{
546 coro_stack *stack;
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)
554 {
555#ifdef 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_ANON, 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 }
108 } 565 }
109 Safefree(PL_tmps_stack); 566 else
110 Safefree(PL_markstack); 567 stack->sptr = 0;
111 Safefree(PL_scopestack); 568
112 Safefree(PL_savestack); 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
113 Safefree(PL_retstack); 590 Safefree (stack);
591 }
592 else if (ctx->gencnt == stack->gencnt)
593 --stack->usecnt;
594 }
114} 595}
115 596
597static void
598setup_coro (void *arg)
599{
600 /*
601 * emulate part of the perl startup here.
602 */
603 dSP;
604 Coro__State ctx = (Coro__State)arg;
605 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
606
607 coro_init_stacks (aTHX);
608 JMPENV_BOOTSTRAP;
609 SPAGAIN;
610
611 /*PL_curcop = 0;*/
612 SvREFCNT_dec (GvAV (PL_defgv));
613 GvAV (PL_defgv) = ctx->args;
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);
622 croak ("FATAL: CCTXT coroutine returned!");
623 }
624 else
625 {
626 UNOP myop;
627
628 PL_op = (OP *)&myop;
629
630 Zero(&myop, 1, UNOP);
631 myop.op_next = Nullop;
632 myop.op_flags = OPf_WANT_VOID;
633
634 PUSHMARK(SP);
635 XPUSHs (sub_init);
636 /*
637 * the next line is slightly wrong, as PL_op->op_next
638 * is actually being executed so we skip the first op.
639 * that doesn't matter, though, since it is only
640 * pp_nextstate and we never return...
641 * ah yes, and I don't care anyways ;)
642 */
643 PUTBACK;
644 PL_op = pp_entersub();
645 SPAGAIN;
646
647 ENTER; /* necessary e.g. for dounwind */
648 }
649}
650
651static void
652continue_coro (void *arg)
653{
654 /*
655 * this is a _very_ stripped down perl interpreter ;)
656 */
657 Coro__State ctx = (Coro__State)arg;
658
659 ctx->cursp = 0;
660 PL_op = PL_op->op_next;
661 CALLRUNOPS(aTHX);
662 /*NORETURN*/
663 abort ();
664}
665
666STATIC void
667transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
668{
669 dSP;
670 dSTACKLEVEL;
671
672 if (prev != next)
673 {
674 if (next->mainstack)
675 {
676 SAVE (prev, flags);
677 LOAD (next);
678
679 /* mark this state as in-use */
680 next->mainstack = 0;
681 next->tmps_ix = -2;
682
683 /* stacklevel changed? if yes, grab the stack for us! */
684 if (flags & TRANSFER_SAVE_CCTXT)
685 {
686 if (!prev->stack)
687 allocate_stack (prev, 0);
688 else if (prev->cursp != stacklevel
689 && prev->stack->usecnt > 1)
690 {
691 prev->gencnt = ++prev->stack->gencnt;
692 prev->stack->usecnt = 1;
693 }
694
695 /* has our stack been invalidated? */
696 if (next->stack && next->stack->gencnt != next->gencnt)
697 {
698 deallocate_stack (next);
699 allocate_stack (next, 1);
700 coro_create (&(next->stack->cctx),
701 continue_coro, (void *)next,
702 next->stack->sptr, labs (next->stack->ssize));
703 }
704
705 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
706 }
707
708 }
709 else if (next->tmps_ix == -2)
710 croak ("tried to transfer to running coroutine");
711 else
712 {
713 SAVE (prev, -1); /* first get rid of the old state */
714
715 if (flags & TRANSFER_SAVE_CCTXT)
716 {
717 if (!prev->stack)
718 allocate_stack (prev, 0);
719
720 if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
721 {
722 setup_coro (next);
723
724 prev->stack->refcnt++;
725 prev->stack->usecnt++;
726 next->stack = prev->stack;
727 next->gencnt = prev->gencnt;
728 }
729 else
730 {
731 allocate_stack (next, 1);
732 coro_create (&(next->stack->cctx),
733 setup_coro, (void *)next,
734 next->stack->sptr, labs (next->stack->ssize));
735 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
736 }
737 }
738 else
739 setup_coro (next);
740 }
741 }
742
743 next->cursp = stacklevel;
744}
745
116MODULE = Coro::State PACKAGE = Coro::State 746MODULE = Coro::State PACKAGE = Coro::State
117 747
118PROTOTYPES: ENABLE 748PROTOTYPES: ENABLE
119 749
750BOOT:
751{ /* {} necessary for stoopid perl-5.6.x */
752 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
753 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
754 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
755
756 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
757 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
758 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
759 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
760
761 if (!padlist_cache)
762 padlist_cache = newHV ();
763
764 main_mainstack = PL_mainstack;
765}
766
120Coro::State 767Coro::State
121newprocess(proc) 768_newprocess(args)
122 SV * proc 769 SV * args
123 PROTOTYPE: & 770 PROTOTYPE: $
124 CODE: 771 CODE:
125 Coro__State coro; 772 Coro__State coro;
773
774 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
775 croak ("Coro::State::_newprocess expects an arrayref");
126 776
127 New (0, coro, 1, struct coro); 777 New (0, coro, 1, struct coro);
128 778
779 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
129 coro->mainstack = 0; /* actual work is done inside transfer */ 780 coro->mainstack = 0; /* actual work is done inside transfer */
130 coro->proc = SvREFCNT_inc (proc); 781 coro->stack = 0;
131 782
132 RETVAL = coro; 783 RETVAL = coro;
133 OUTPUT: 784 OUTPUT:
134 RETVAL 785 RETVAL
135 786
136void 787void
137transfer(prev,next) 788transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
138 Coro::State_or_hashref prev 789 Coro::State_or_hashref prev
139 Coro::State_or_hashref next 790 Coro::State_or_hashref next
791 int flags
792 PROTOTYPE: @
140 CODE: 793 CODE:
141 794 transfer (aTHX_ prev, next, flags);
142 PUTBACK;
143 SAVE (prev);
144
145 /*
146 * this could be done in newprocess which would to
147 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
148 * code here, but lazy allocation of stacks has also
149 * some virtues and the overhead of the if() is nil.
150 */
151 if (next->mainstack)
152 {
153 LOAD (next);
154 next->mainstack = 0; /* unnecessary but much cleaner */
155 SPAGAIN;
156 }
157 else
158 {
159 /*
160 * emulate part of the perl startup here.
161 */
162 UNOP myop;
163
164 init_stacks ();
165 PL_op = (OP *)&myop;
166 /*PL_curcop = 0;*/
167
168 SPAGAIN;
169 Zero(&myop, 1, UNOP);
170 myop.op_next = Nullop;
171 myop.op_flags = OPf_WANT_VOID;
172
173 EXTEND (SP,1);
174 PUSHs (next->proc);
175
176 PUTBACK;
177 /*
178 * the next line is slightly wrong, as PL_op->op_next
179 * is actually being executed so we skip the first op
180 * that doens't matter, though, since it is only
181 * pp_nextstate and we never return...
182 */
183 PL_op = Perl_pp_entersub(aTHX);
184 SPAGAIN;
185
186 ENTER;
187 }
188 795
189void 796void
190DESTROY(coro) 797DESTROY(coro)
191 Coro::State coro 798 Coro::State coro
192 CODE: 799 CODE:
193 800
194 if (coro->mainstack) 801 if (coro->mainstack && coro->mainstack != main_mainstack)
195 { 802 {
196 struct coro temp; 803 struct coro temp;
197 804
198 PUTBACK; 805 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
199 SAVE((&temp));
200 LOAD(coro); 806 LOAD(aTHX_ coro);
201 807
202 S_nuke_stacks (); 808 destroy_stacks (aTHX);
203 809
204 LOAD((&temp)); 810 LOAD((&temp)); /* this will get rid of defsv etc.. */
205 SPAGAIN; 811
812 coro->mainstack = 0;
206 } 813 }
207 814
208 SvREFCNT_dec (coro->proc); 815 deallocate_stack (coro);
816
209 Safefree (coro); 817 Safefree (coro);
210 818
819void
820flush()
821 CODE:
822#ifdef MAY_FLUSH
823 flush_padlist_cache ();
824#endif
211 825
826MODULE = Coro::State PACKAGE = Coro::Cont
827
828# this is slightly dirty
829
830void
831yield(...)
832 PROTOTYPE: @
833 CODE:
834 static SV *returnstk;
835 SV *sv;
836 AV *defav = GvAV (PL_defgv);
837 struct coro *prev, *next;
838
839 if (!returnstk)
840 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
841
842 /* set up @_ -- ugly */
843 av_clear (defav);
844 av_fill (defav, items - 1);
845 while (items--)
846 av_store (defav, items, SvREFCNT_inc (ST(items)));
847
848 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
849 sv = av_pop ((AV *)SvRV (returnstk));
850 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
851 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
852 SvREFCNT_dec (sv);
853
854 transfer(aTHX_ prev, next, 0);
855

Diff Legend

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