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.2 by root, Sun Jul 15 02:35:52 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 AV *defav; 101 /* data associated with this coroutine (initial args) */
35 102 AV *args;
36 SV *proc;
37}; 103};
38 104
39typedef struct coro *Coro__State; 105typedef struct coro *Coro__State;
40typedef struct coro *Coro__State_or_hashref; 106typedef struct coro *Coro__State_or_hashref;
41 107
42#define SAVE(c) \ 108static AV *main_mainstack; /* used to differentiate between $main and others */
43 c->dowarn = PL_dowarn; \ 109static HV *coro_state_stash;
44 c->curstackinfo = PL_curstackinfo; \ 110static SV *ucoro_state_sv;
45 c->curstack = PL_curstack; \ 111static U32 ucoro_state_hash;
46 c->mainstack = PL_mainstack; \ 112static HV *padlist_cache;
47 c->stack_sp = PL_stack_sp; \
48 c->op = PL_op; \
49 c->curpad = PL_curpad; \
50 c->stack_base = PL_stack_base; \
51 c->stack_max = PL_stack_max; \
52 c->tmps_stack = PL_tmps_stack; \
53 c->tmps_floor = PL_tmps_floor; \
54 c->tmps_ix = PL_tmps_ix; \
55 c->tmps_max = PL_tmps_max; \
56 c->markstack = PL_markstack; \
57 c->markstack_ptr = PL_markstack_ptr; \
58 c->markstack_max = PL_markstack_max; \
59 c->scopestack = PL_scopestack; \
60 c->scopestack_ix = PL_scopestack_ix; \
61 c->scopestack_max = PL_scopestack_max;\
62 c->savestack = PL_savestack; \
63 c->savestack_ix = PL_savestack_ix; \
64 c->savestack_max = PL_savestack_max; \
65 c->retstack = PL_retstack; \
66 c->retstack_ix = PL_retstack_ix; \
67 c->retstack_max = PL_retstack_max; \
68 c->curcop = PL_curcop; \
69 c->defav = GvAV (PL_defgv);
70 113
71#define LOAD(c) \ 114/* mostly copied from op.c:cv_clone2 */
72 PL_dowarn = c->dowarn; \ 115STATIC AV *
73 PL_curstackinfo = c->curstackinfo; \ 116clone_padlist (AV *protopadlist)
74 PL_curstack = c->curstack; \ 117{
75 PL_mainstack = c->mainstack; \ 118 AV *av;
76 PL_stack_sp = c->stack_sp; \ 119 I32 ix;
77 PL_op = c->op; \ 120 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
78 PL_curpad = c->curpad; \ 121 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
79 PL_stack_base = c->stack_base; \ 122 SV **pname = AvARRAY (protopad_name);
80 PL_stack_max = c->stack_max; \ 123 SV **ppad = AvARRAY (protopad);
81 PL_tmps_stack = c->tmps_stack; \ 124 I32 fname = AvFILLp (protopad_name);
82 PL_tmps_floor = c->tmps_floor; \ 125 I32 fpad = AvFILLp (protopad);
83 PL_tmps_ix = c->tmps_ix; \ 126 AV *newpadlist, *newpad_name, *newpad;
84 PL_tmps_max = c->tmps_max; \ 127 SV **npad;
85 PL_markstack = c->markstack; \
86 PL_markstack_ptr = c->markstack_ptr; \
87 PL_markstack_max = c->markstack_max; \
88 PL_scopestack = c->scopestack; \
89 PL_scopestack_ix = c->scopestack_ix; \
90 PL_scopestack_max = c->scopestack_max;\
91 PL_savestack = c->savestack; \
92 PL_savestack_ix = c->savestack_ix; \
93 PL_savestack_max = c->savestack_max; \
94 PL_retstack = c->retstack; \
95 PL_retstack_ix = c->retstack_ix; \
96 PL_retstack_max = c->retstack_max; \
97 PL_curcop = c->curcop; \
98 GvAV (PL_defgv) = c->defav;
99 128
100/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 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 */
101STATIC void 230STATIC void
102S_nuke_stacks(pTHX) 231get_padlist (CV *cv)
103{ 232{
104 while (PL_curstackinfo->si_next) 233 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
105 PL_curstackinfo = PL_curstackinfo->si_next; 234
106 while (PL_curstackinfo) { 235 if (he && AvFILLp ((AV *)*he) >= 0)
107 PERL_SI *p = PL_curstackinfo->si_prev; 236 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
108 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 237 else
109 Safefree(PL_curstackinfo->si_cxstack); 238 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
110 Safefree(PL_curstackinfo); 239}
111 PL_curstackinfo = p; 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 ();
112 } 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
427 c->dowarn = PL_dowarn;
428
429 c->curstackinfo = PL_curstackinfo;
430 c->curstack = PL_curstack;
431 c->mainstack = PL_mainstack;
432 c->stack_sp = PL_stack_sp;
433 c->op = PL_op;
434 c->curpad = PL_curpad;
435 c->stack_base = PL_stack_base;
436 c->stack_max = PL_stack_max;
437 c->tmps_stack = PL_tmps_stack;
438 c->tmps_floor = PL_tmps_floor;
439 c->tmps_ix = PL_tmps_ix;
440 c->tmps_max = PL_tmps_max;
441 c->markstack = PL_markstack;
442 c->markstack_ptr = PL_markstack_ptr;
443 c->markstack_max = PL_markstack_max;
444 c->scopestack = PL_scopestack;
445 c->scopestack_ix = PL_scopestack_ix;
446 c->scopestack_max = PL_scopestack_max;
447 c->savestack = PL_savestack;
448 c->savestack_ix = PL_savestack_ix;
449 c->savestack_max = PL_savestack_max;
450 c->retstack = PL_retstack;
451 c->retstack_ix = PL_retstack_ix;
452 c->retstack_max = PL_retstack_max;
453 c->curcop = PL_curcop;
454 c->start_env = PL_start_env;
455 c->top_env = PL_top_env;
456}
457
458/*
459 * allocate various perl stacks. This is an exact copy
460 * of perl.c:init_stacks, except that it uses less memory
461 * on the assumption that coroutines do not usually need
462 * a lot of stackspace.
463 */
464STATIC void
465coro_init_stacks (pTHX)
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
515 while (PL_curstackinfo->si_next)
516 PL_curstackinfo = PL_curstackinfo->si_next;
517
518 while (PL_curstackinfo)
519 {
520 PERL_SI *p = PL_curstackinfo->si_prev;
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);
531 Safefree(PL_curstackinfo->si_cxstack);
532 Safefree(PL_curstackinfo);
533 PL_curstackinfo = p;
534 }
535
113 Safefree(PL_tmps_stack); 536 Safefree(PL_tmps_stack);
114 Safefree(PL_markstack); 537 Safefree(PL_markstack);
115 Safefree(PL_scopestack); 538 Safefree(PL_scopestack);
116 Safefree(PL_savestack); 539 Safefree(PL_savestack);
117 Safefree(PL_retstack); 540 Safefree(PL_retstack);
118} 541}
119 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 }
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 */
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
120MODULE = Coro::State PACKAGE = Coro::State 746MODULE = Coro::State PACKAGE = Coro::State
121 747
122PROTOTYPES: ENABLE 748PROTOTYPES: ENABLE
123 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
124Coro::State 767Coro::State
125newprocess(proc) 768_newprocess(args)
126 SV * proc 769 SV * args
127 PROTOTYPE: & 770 PROTOTYPE: $
128 CODE: 771 CODE:
129 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");
130 776
131 New (0, coro, 1, struct coro); 777 New (0, coro, 1, struct coro);
132 778
779 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
133 coro->mainstack = 0; /* actual work is done inside transfer */ 780 coro->mainstack = 0; /* actual work is done inside transfer */
134 coro->proc = SvREFCNT_inc (proc); 781 coro->stack = 0;
135 782
136 RETVAL = coro; 783 RETVAL = coro;
137 OUTPUT: 784 OUTPUT:
138 RETVAL 785 RETVAL
139 786
140void 787void
141transfer(prev,next) 788transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
142 Coro::State_or_hashref prev 789 Coro::State_or_hashref prev
143 Coro::State_or_hashref next 790 Coro::State_or_hashref next
791 int flags
792 PROTOTYPE: @
144 CODE: 793 CODE:
145 794 transfer (aTHX_ prev, next, flags);
146 if (prev != next)
147 {
148 PUTBACK;
149 SAVE (prev);
150
151 /*
152 * this could be done in newprocess which would to
153 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
154 * code here, but lazy allocation of stacks has also
155 * some virtues and the overhead of the if() is nil.
156 */
157 if (next->mainstack)
158 {
159 LOAD (next);
160 next->mainstack = 0; /* unnecessary but much cleaner */
161 SPAGAIN;
162 }
163 else
164 {
165 /*
166 * emulate part of the perl startup here.
167 */
168 UNOP myop;
169
170 init_stacks ();
171 PL_op = (OP *)&myop;
172 /*PL_curcop = 0;*/
173 GvAV (PL_defgv) = newAV ();
174
175 SPAGAIN;
176 Zero(&myop, 1, UNOP);
177 myop.op_next = Nullop;
178 myop.op_flags = OPf_WANT_VOID;
179
180 EXTEND (SP,1);
181 PUSHs (next->proc);
182
183 PUTBACK;
184 /*
185 * the next line is slightly wrong, as PL_op->op_next
186 * is actually being executed so we skip the first op
187 * that doens't matter, though, since it is only
188 * pp_nextstate and we never return...
189 */
190 PL_op = Perl_pp_entersub(aTHX);
191 SPAGAIN;
192
193 ENTER;
194 }
195 }
196 795
197void 796void
198DESTROY(coro) 797DESTROY(coro)
199 Coro::State coro 798 Coro::State coro
200 CODE: 799 CODE:
201 800
202 if (coro->mainstack) 801 if (coro->mainstack && coro->mainstack != main_mainstack)
203 { 802 {
204 struct coro temp; 803 struct coro temp;
205 804
206 PUTBACK; 805 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
207 SAVE((&temp));
208 LOAD(coro); 806 LOAD(aTHX_ coro);
209 807
210 S_nuke_stacks (); 808 destroy_stacks (aTHX);
211 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
212 809
213 LOAD((&temp)); 810 LOAD((&temp)); /* this will get rid of defsv etc.. */
214 SPAGAIN; 811
812 coro->mainstack = 0;
215 } 813 }
216 814
217 SvREFCNT_dec (coro->proc); 815 deallocate_stack (coro);
816
218 Safefree (coro); 817 Safefree (coro);
219 818
819void
820flush()
821 CODE:
822#ifdef MAY_FLUSH
823 flush_padlist_cache ();
824#endif
220 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