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.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.13 by root, Mon Jul 23 22:09:39 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#else 7#ifdef HAVE_MMAP
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 8# include <unistd.h>
9# include <sys/mman.h>
9#endif 10#endif
11
12#define MAY_FLUSH /* increases codesize */
13
14#define SUB_INIT "Coro::State::initialize"
15
16#define TRANSFER_SAVE_DEFAV 0x00000001
17#define TRANSFER_SAVE_DEFSV 0x00000002
18#define TRANSFER_SAVE_ERRSV 0x00000004
19#define TRANSFER_SAVE_CCTXT 0x00000008
20
21#define TRANSFER_SAVE_ALL -1
10 22
11struct coro { 23struct coro {
24 /* the optional C context */
25 coro_context cctx;
26 void *sptr;
27 long ssize;
28
29 /* optionally saved, might be zero */
30 AV *defav;
31 SV *defsv;
32 SV *errsv;
33
34 /* saved global state not related to stacks */
12 U8 dowarn; 35 U8 dowarn;
13 AV *defav; 36
14 37 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 38 PERL_SI *curstackinfo;
16 AV *curstack; 39 AV *curstack;
17 AV *mainstack; 40 AV *mainstack;
18 SV **stack_sp; 41 SV **stack_sp;
19 OP *op; 42 OP *op;
… …
35 I32 savestack_max; 58 I32 savestack_max;
36 OP **retstack; 59 OP **retstack;
37 I32 retstack_ix; 60 I32 retstack_ix;
38 I32 retstack_max; 61 I32 retstack_max;
39 COP *curcop; 62 COP *curcop;
63 JMPENV start_env;
64 JMPENV *top_env;
40 65
66 /* data associated with this coroutine (initial args) */
41 AV *args; 67 AV *args;
42}; 68};
43 69
44typedef struct coro *Coro__State; 70typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 71typedef struct coro *Coro__State_or_hashref;
46 72
73static AV *main_mainstack; /* used to differentiate between $main and others */
74static HV *coro_state_stash;
47static HV *padlist_cache; 75static HV *padlist_cache;
48 76
49/* mostly copied from op.c:cv_clone2 */ 77/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 78STATIC AV *
51clone_padlist (AV *protopadlist) 79clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 143 SvPADTMP_on (sv);
116 npad[ix] = sv; 144 npad[ix] = sv;
117 } 145 }
118 } 146 }
119 147
120#if 0 /* NONOTUNDERSTOOD */ 148#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 149 /* Now that vars are all in place, clone nested closures. */
122 150
123 for (ix = fpad; ix > 0; ix--) { 151 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 152 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 153 if (namesv
… …
138#endif 166#endif
139 167
140 return newpadlist; 168 return newpadlist;
141} 169}
142 170
171#ifdef MAY_FLUSH
143STATIC AV * 172STATIC AV *
144free_padlist (AV *padlist) 173free_padlist (AV *padlist)
145{ 174{
146 /* may be during global destruction */ 175 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 176 if (SvREFCNT(padlist))
… …
156 } 185 }
157 186
158 SvREFCNT_dec((SV*)padlist); 187 SvREFCNT_dec((SV*)padlist);
159 } 188 }
160} 189}
190#endif
161 191
162/* the next tow functions merely cache the padlists */ 192/* the next two functions merely cache the padlists */
163STATIC void 193STATIC void
164get_padlist (CV *cv) 194get_padlist (CV *cv)
165{ 195{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0); 196 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167 197
… …
183 } 213 }
184 214
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv)); 215 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186} 216}
187 217
218#ifdef MAY_FLUSH
219STATIC void
220flush_padlist_cache ()
221{
222 HV *hv = padlist_cache;
223 padlist_cache = newHV ();
224
225 if (hv_iterinit (hv))
226 {
227 HE *he;
228 AV *padlist;
229
230 while (!!(he = hv_iternext (hv)))
231 {
232 AV *av = (AV *)HeVAL(he);
233
234 /* casting is fun. */
235 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
236 free_padlist (padlist);
237 }
238 }
239
240 SvREFCNT_dec (hv);
241}
242#endif
243
244#define SB do {
245#define SE } while (0)
246
247#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
248#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
249
250#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
251
188static void 252static void
189SAVE(pTHX_ Coro__State c) 253load_state(pTHX_ Coro__State c)
254{
255 PL_dowarn = c->dowarn;
256
257 PL_curstackinfo = c->curstackinfo;
258 PL_curstack = c->curstack;
259 PL_mainstack = c->mainstack;
260 PL_stack_sp = c->stack_sp;
261 PL_op = c->op;
262 PL_curpad = c->curpad;
263 PL_stack_base = c->stack_base;
264 PL_stack_max = c->stack_max;
265 PL_tmps_stack = c->tmps_stack;
266 PL_tmps_floor = c->tmps_floor;
267 PL_tmps_ix = c->tmps_ix;
268 PL_tmps_max = c->tmps_max;
269 PL_markstack = c->markstack;
270 PL_markstack_ptr = c->markstack_ptr;
271 PL_markstack_max = c->markstack_max;
272 PL_scopestack = c->scopestack;
273 PL_scopestack_ix = c->scopestack_ix;
274 PL_scopestack_max = c->scopestack_max;
275 PL_savestack = c->savestack;
276 PL_savestack_ix = c->savestack_ix;
277 PL_savestack_max = c->savestack_max;
278 PL_retstack = c->retstack;
279 PL_retstack_ix = c->retstack_ix;
280 PL_retstack_max = c->retstack_max;
281 PL_curcop = c->curcop;
282 PL_start_env = c->start_env;
283 PL_top_env = c->top_env;
284
285 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
286 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
287 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
288
289 {
290 dSP;
291 CV *cv;
292
293 /* now do the ugly restore mess */
294 while ((cv = (CV *)POPs))
295 {
296 AV *padlist = (AV *)POPs;
297
298 if (padlist)
299 {
300 put_padlist (cv); /* mark this padlist as available */
301 CvPADLIST(cv) = padlist;
302#ifdef USE_THREADS
303 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
304#endif
305 }
306
307 ++CvDEPTH(cv);
308 }
309
310 PUTBACK;
311 }
312}
313
314static void
315save_state(pTHX_ Coro__State c, int flags)
190{ 316{
191 { 317 {
192 dSP; 318 dSP;
193 I32 cxix = cxstack_ix; 319 I32 cxix = cxstack_ix;
320 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 321 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 322
197 /* 323 /*
198 * the worst thing you can imagine happens first - we have to save 324 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 325 * (and reinitialize) all cv's in the whole callchain :(
200 */ 326 */
201 327
202 PUSHs (Nullsv); 328 PUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 329 /* this loop was inspired by pp_caller */
204 for (;;) 330 for (;;)
205 { 331 {
206 while (cxix >= 0) 332 do
207 { 333 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 334 PERL_CONTEXT *cx = &ccstk[cxix--];
209 335
210 if (CxTYPE(cx) == CXt_SUB) 336 if (CxTYPE(cx) == CXt_SUB)
211 { 337 {
212 CV *cv = cx->blk_sub.cv; 338 CV *cv = cx->blk_sub.cv;
213 if (CvDEPTH(cv)) 339 if (CvDEPTH(cv))
214 { 340 {
215#ifdef USE_THREADS 341#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv)); 342 /*XPUSHs ((SV *)CvOWNER(cv));*/
343 /*CvOWNER(cv) = 0;*/
344 /*error must unlock this cv etc.. etc...*/
217#endif 345#endif
218 EXTEND (SP, 3); 346 EXTEND (SP, CvDEPTH(cv)*2);
347
348 while (--CvDEPTH(cv))
349 {
350 /* this tells the restore code to increment CvDEPTH */
351 PUSHs (Nullsv);
219 PUSHs ((SV *)CvDEPTH(cv)); 352 PUSHs ((SV *)cv);
353 }
354
220 PUSHs ((SV *)CvPADLIST(cv)); 355 PUSHs ((SV *)CvPADLIST(cv));
221 PUSHs ((SV *)cv); 356 PUSHs ((SV *)cv);
222 357
223 get_padlist (cv); 358 get_padlist (cv); /* this is a monster */
224
225 CvDEPTH(cv) = 0;
226#ifdef USE_THREADS
227 CvOWNER(cv) = 0;
228 error must unlock this cv etc.. etc...
229 if you are here wondering about this error message then
230 the reason is that it will not work as advertised yet
231#endif
232 } 359 }
233 } 360 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 361 else if (CxTYPE(cx) == CXt_FORMAT)
235 { 362 {
236 /* I never used formats, so how should I know how these are implemented? */ 363 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */ 364 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 365 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 } 366 }
240 } 367 }
368 while (cxix >= 0);
241 369
242 if (top_si->si_type == PERLSI_MAIN) 370 if (top_si->si_type == PERLSI_MAIN)
243 break; 371 break;
244 372
245 top_si = top_si->si_prev; 373 top_si = top_si->si_prev;
… …
248 } 376 }
249 377
250 PUTBACK; 378 PUTBACK;
251 } 379 }
252 380
381 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
382 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
383 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
384
385 /* I have not the slightest idea of why av_reify is necessary */
386 /* but if it's missing the defav contents magically get replaced sometimes */
387 if (c->defav)
388 av_reify (c->defav);
389
253 c->dowarn = PL_dowarn; 390 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv); 391
255 c->curstackinfo = PL_curstackinfo; 392 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack; 393 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack; 394 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp; 395 c->stack_sp = PL_stack_sp;
259 c->op = PL_op; 396 c->op = PL_op;
… …
275 c->savestack_max = PL_savestack_max; 412 c->savestack_max = PL_savestack_max;
276 c->retstack = PL_retstack; 413 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix; 414 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max; 415 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop; 416 c->curcop = PL_curcop;
417 c->start_env = PL_start_env;
418 c->top_env = PL_top_env;
280} 419}
281 420
282static void 421/*
283LOAD(pTHX_ Coro__State c) 422 * allocate various perl stacks. This is an exact copy
423 * of perl.c:init_stacks, except that it uses less memory
424 * on the assumption that coroutines do not usually need
425 * a lot of stackspace.
426 */
427STATIC void
428coro_init_stacks (pTHX)
284{ 429{
285 PL_dowarn = c->dowarn; 430 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286 GvAV (PL_defgv) = c->defav; 431 PL_curstackinfo->si_type = PERLSI_MAIN;
287 PL_curstackinfo = c->curstackinfo; 432 PL_curstack = PL_curstackinfo->si_stack;
288 PL_curstack = c->curstack; 433 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289 PL_mainstack = c->mainstack; 434
435 PL_stack_base = AvARRAY(PL_curstack);
290 PL_stack_sp = c->stack_sp; 436 PL_stack_sp = PL_stack_base;
291 PL_op = c->op; 437 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292 PL_curpad = c->curpad; 438
293 PL_stack_base = c->stack_base; 439 New(50,PL_tmps_stack,64,SV*);
294 PL_stack_max = c->stack_max; 440 PL_tmps_floor = -1;
295 PL_tmps_stack = c->tmps_stack; 441 PL_tmps_ix = -1;
296 PL_tmps_floor = c->tmps_floor; 442 PL_tmps_max = 64;
297 PL_tmps_ix = c->tmps_ix; 443
298 PL_tmps_max = c->tmps_max; 444 New(54,PL_markstack,12,I32);
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr; 445 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 446 PL_markstack_max = PL_markstack + 12;
302 PL_scopestack = c->scopestack;
303 PL_scopestack_ix = c->scopestack_ix;
304 PL_scopestack_max = c->scopestack_max;
305 PL_savestack = c->savestack;
306 PL_savestack_ix = c->savestack_ix;
307 PL_savestack_max = c->savestack_max;
308 PL_retstack = c->retstack;
309 PL_retstack_ix = c->retstack_ix;
310 PL_retstack_max = c->retstack_max;
311 PL_curcop = c->curcop;
312 447
313 { 448 SET_MARK_OFFSET;
314 dSP;
315 CV *cv;
316 449
317 /* now do the ugly restore mess */ 450 New(54,PL_scopestack,12,I32);
318 while ((cv = (CV *)POPs)) 451 PL_scopestack_ix = 0;
319 { 452 PL_scopestack_max = 12;
320 AV *padlist = (AV *)POPs;
321 453
322 put_padlist (cv); 454 New(54,PL_savestack,64,ANY);
323 CvPADLIST(cv) = padlist; 455 PL_savestack_ix = 0;
324 CvDEPTH(cv) = (I32)POPs; 456 PL_savestack_max = 64;
325 457
326#ifdef USE_THREADS 458 New(54,PL_retstack,8,OP*);
327 CvOWNER(cv) = (struct perl_thread *)POPs; 459 PL_retstack_ix = 0;
328 error does not work either 460 PL_retstack_max = 8;
329#endif
330 }
331
332 PUTBACK;
333 }
334} 461}
335 462
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 463/*
464 * destroy the stacks, the callchain etc...
465 * still there is a memleak of 128 bytes...
466 */
337STATIC void 467STATIC void
338destroy_stacks(pTHX) 468destroy_stacks(pTHX)
339{ 469{
340 dSP;
341
342 /* die does this while calling POPSTACK, but I just don't see why. */
343 dounwind(-1);
344
345 /* is this ugly, I ask? */ 470 /* is this ugly, I ask? */
346 while (PL_scopestack_ix) 471 while (PL_scopestack_ix)
347 LEAVE; 472 LEAVE;
348 473
474 /* sure it is, but more important: is it correct?? :/ */
475 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
476 FREETMPS;
477
349 while (PL_curstackinfo->si_next) 478 while (PL_curstackinfo->si_next)
350 PL_curstackinfo = PL_curstackinfo->si_next; 479 PL_curstackinfo = PL_curstackinfo->si_next;
351 480
352 while (PL_curstackinfo) 481 while (PL_curstackinfo)
353 { 482 {
354 PERL_SI *p = PL_curstackinfo->si_prev; 483 PERL_SI *p = PL_curstackinfo->si_prev;
484
485 {
486 dSP;
487 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
488 PUTBACK; /* possibly superfluous */
489 }
490
491 dounwind(-1);
355 492
356 SvREFCNT_dec(PL_curstackinfo->si_stack); 493 SvREFCNT_dec(PL_curstackinfo->si_stack);
357 Safefree(PL_curstackinfo->si_cxstack); 494 Safefree(PL_curstackinfo->si_cxstack);
358 Safefree(PL_curstackinfo); 495 Safefree(PL_curstackinfo);
359 PL_curstackinfo = p; 496 PL_curstackinfo = p;
360 } 497 }
361 498
362 if (PL_scopestack_ix != 0)
363 Perl_warner(aTHX_ WARN_INTERNAL,
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365 (long)PL_scopestack_ix);
366 if (PL_savestack_ix != 0)
367 Perl_warner(aTHX_ WARN_INTERNAL,
368 "Unbalanced saves: %ld more saves than restores\n",
369 (long)PL_savestack_ix);
370 if (PL_tmps_floor != -1)
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372 (long)PL_tmps_floor + 1);
373 /*
374 */
375 Safefree(PL_tmps_stack); 499 Safefree(PL_tmps_stack);
376 Safefree(PL_markstack); 500 Safefree(PL_markstack);
377 Safefree(PL_scopestack); 501 Safefree(PL_scopestack);
378 Safefree(PL_savestack); 502 Safefree(PL_savestack);
379 Safefree(PL_retstack); 503 Safefree(PL_retstack);
380} 504}
381 505
382#define SUB_INIT "Coro::State::_newcoro" 506static void
507allocate_stack (Coro__State ctx)
508{
509#ifdef HAVE_MMAP
510 ctx->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
511 ctx->sptr = mmap (0, ctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
512 if (ctx->sptr == (void *)-1)
513#endif
514 {
515 /*FIXME*//*D*//* reasonable stack size! */
516 ctx->ssize = 4096 * sizeof (long);
517 New (0, ctx->sptr, 4096, long);
518 }
519}
520
521static void
522deallocate_stack (Coro__State ctx)
523{
524#ifdef HAVE_MMAP
525 munmap (ctx->sptr, ctx->ssize);
526#else
527 Safefree (ctx->sptr);
528#endif
529}
530
531/* might go away together with optional SAVE_CCTXT */
532static void
533setup_coro (void *arg)
534{
535 /*
536 * emulate part of the perl startup here.
537 */
538 dSP;
539 Coro__State ctx = (Coro__State)arg;
540 SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);
541
542 coro_init_stacks (aTHX);
543 JMPENV_BOOTSTRAP;
544 SPAGAIN;
545
546 /*PL_curcop = 0;*/
547 SvREFCNT_dec (GvAV (PL_defgv));
548 GvAV (PL_defgv) = ctx->args;
549
550 if (ctx->sptr)
551 {
552 PUSHMARK(SP);
553 PUTBACK;
554 (void) call_sv (sub_init, G_VOID|G_NOARGS);
555 croak ("FATAL: CCTXT coroutine returned!");
556 }
557 else
558 {
559 UNOP myop;
560
561 PL_op = (OP *)&myop;
562
563 Zero(&myop, 1, UNOP);
564 myop.op_next = Nullop;
565 myop.op_flags = OPf_WANT_VOID;
566
567 PUSHMARK(SP);
568 XPUSHs (sub_init);
569 /*
570 * the next line is slightly wrong, as PL_op->op_next
571 * is actually being executed so we skip the first op.
572 * that doesn't matter, though, since it is only
573 * pp_nextstate and we never return...
574 * ah yes, and I don't care anyways ;)
575 */
576 PUTBACK;
577 PL_op = pp_entersub();
578 SPAGAIN;
579
580 ENTER; /* necessary e.g. for dounwind */
581 }
582}
583
584STATIC void
585transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
586{
587 dSP;
588
589 if (prev != next)
590 {
591 /*
592 * this could be done in newprocess which would lead to
593 * extremely elegant and fast (basically just SAVE/LOAD)
594 * code here, but lazy allocation of stacks has also
595 * some virtues and the overhead of the if() is nil.
596 */
597 if (next->mainstack)
598 {
599 SAVE (prev, flags);
600 LOAD (next);
601
602 /* mark this state as in-use */
603 next->mainstack = 0;
604 next->tmps_ix = -2;
605
606 if (flags & TRANSFER_SAVE_CCTXT)
607 {
608 if (!next->ssize)
609 croak ("destination coroutine has no CCTXT (%p, %d)", next->sptr, next->ssize);
610
611 if (!prev->ssize)
612 prev->ssize = 1; /* mark cctx as valid ;) */
613
614 coro_transfer (&(prev->cctx), &(next->cctx));
615 }
616
617 }
618 else if (next->tmps_ix == -2)
619 croak ("tried to transfer to running coroutine");
620 else
621 {
622 SAVE (prev, -1); /* first get rid of the old state */
623
624 if (flags & TRANSFER_SAVE_CCTXT)
625 {
626 if (!next->ssize)
627 {
628 allocate_stack (next);
629 coro_create (&(next->cctx),
630 setup_coro, (void *)next,
631 next->sptr, next->ssize);
632 }
633
634 if (!prev->ssize)
635 prev->ssize = 1; /* mark cctx as valid ;) */
636
637 coro_transfer (&(prev->cctx), &(next->cctx));
638 }
639 else
640 setup_coro (next);
641 }
642 }
643}
383 644
384MODULE = Coro::State PACKAGE = Coro::State 645MODULE = Coro::State PACKAGE = Coro::State
385 646
386PROTOTYPES: ENABLE 647PROTOTYPES: ENABLE
387 648
388BOOT: 649BOOT:
650{ /* {} necessary for stoopid perl-5.6.x */
651 coro_state_stash = gv_stashpvn ("Coro::State", 10, TRUE);
652
653 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
654 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
655 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
656 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
657
389 if (!padlist_cache) 658 if (!padlist_cache)
390 padlist_cache = newHV (); 659 padlist_cache = newHV ();
660
661 main_mainstack = PL_mainstack;
662}
391 663
392Coro::State 664Coro::State
393_newprocess(args) 665_newprocess(args)
394 SV * args 666 SV * args
395 PROTOTYPE: $ 667 PROTOTYPE: $
396 CODE: 668 CODE:
397 Coro__State coro; 669 Coro__State coro;
398 670
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 671 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400 croak ("Coro::State::newprocess expects an arrayref"); 672 croak ("Coro::State::_newprocess expects an arrayref");
401 673
402 New (0, coro, 1, struct coro); 674 New (0, coro, 1, struct coro);
403 675
676 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404 coro->mainstack = 0; /* actual work is done inside transfer */ 677 coro->mainstack = 0; /* actual work is done inside transfer */
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 678 coro->sptr = 0;
679 coro->ssize = 0;
406 680
407 RETVAL = coro; 681 RETVAL = coro;
408 OUTPUT: 682 OUTPUT:
409 RETVAL 683 RETVAL
410 684
411void 685void
412transfer(prev,next) 686transfer(prev, next, flags = TRANSFER_SAVE_ALL)
413 Coro::State_or_hashref prev 687 Coro::State_or_hashref prev
414 Coro::State_or_hashref next 688 Coro::State_or_hashref next
689 int flags
690 PROTOTYPE: @
415 CODE: 691 CODE:
416 692 transfer (aTHX_ prev, next, flags);
417 if (prev != next)
418 {
419 PUTBACK;
420 SAVE (aTHX_ prev);
421
422 /*
423 * this could be done in newprocess which would lead to
424 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425 * code here, but lazy allocation of stacks has also
426 * some virtues and the overhead of the if() is nil.
427 */
428 if (next->mainstack)
429 {
430 LOAD (aTHX_ next);
431 next->mainstack = 0; /* unnecessary but much cleaner */
432 SPAGAIN;
433 }
434 else
435 {
436 /*
437 * emulate part of the perl startup here.
438 */
439 UNOP myop;
440
441 init_stacks (); /* from perl.c */
442 PL_op = (OP *)&myop;
443 /*PL_curcop = 0;*/
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446 SPAGAIN;
447 Zero(&myop, 1, UNOP);
448 myop.op_next = Nullop;
449 myop.op_flags = OPf_WANT_VOID;
450
451 PUSHMARK(SP);
452 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453 PUTBACK;
454 /*
455 * the next line is slightly wrong, as PL_op->op_next
456 * is actually being executed so we skip the first op.
457 * that doesn't matter, though, since it is only
458 * pp_nextstate and we never return...
459 */
460 PL_op = Perl_pp_entersub(aTHX);
461 SPAGAIN;
462
463 ENTER;
464 }
465 }
466 693
467void 694void
468DESTROY(coro) 695DESTROY(coro)
469 Coro::State coro 696 Coro::State coro
470 CODE: 697 CODE:
471 698
472 if (coro->mainstack) 699 if (coro->mainstack && coro->mainstack != main_mainstack)
473 { 700 {
474 struct coro temp; 701 struct coro temp;
475 702
476 PUTBACK;
477 SAVE(aTHX_ (&temp)); 703 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
478 LOAD(aTHX_ coro); 704 LOAD(aTHX_ coro);
479 705
480 destroy_stacks (); 706 destroy_stacks (aTHX);
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482 707
483 LOAD((&temp)); 708 LOAD((&temp)); /* this will get rid of defsv etc.. */
484 SPAGAIN; 709
710 coro->mainstack = 0;
485 } 711 }
486 712
487 SvREFCNT_dec (coro->args); 713 if (coro->sptr)
714 {
715 deallocate_stack (coro);
716 coro->sptr = 0;
717 }
718
488 Safefree (coro); 719 Safefree (coro);
489 720
721void
722flush()
723 CODE:
724#ifdef MAY_FLUSH
725 flush_padlist_cache ();
726#endif
490 727
728MODULE = Coro::State PACKAGE = Coro::Cont
729
730# this is slightly dirty
731
732void
733yield(...)
734 PROTOTYPE: @
735 CODE:
736 static SV *returnstk;
737 SV *sv;
738 AV *defav = GvAV (PL_defgv);
739 struct coro *prev, *next;
740
741 if (!returnstk)
742 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
743
744 /* set up @_ -- ugly */
745 av_clear (defav);
746 av_fill (defav, items - 1);
747 while (items--)
748 av_store (defav, items, SvREFCNT_inc (ST(items)));
749
750 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
751 sv = av_pop ((AV *)SvRV (returnstk));
752 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
753 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
754 SvREFCNT_dec (sv);
755
756 transfer(aTHX_ prev, next, 0);
757

Diff Legend

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