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.6 by root, Tue Jul 17 15:42:28 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_state(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
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 421/*
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 422 * allocate various perl stacks. This is an exact copy
284 423 * of perl.c:init_stacks, except that it uses less memory
285static void 424 * on the assumption that coroutines do not usually need
286load_state(pTHX_ Coro__State c) 425 * a lot of stackspace.
426 */
427STATIC void
428coro_init_stacks (pTHX)
287{ 429{
288 PL_dowarn = c->dowarn; 430 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
289 GvAV (PL_defgv) = c->defav; 431 PL_curstackinfo->si_type = PERLSI_MAIN;
290 PL_curstackinfo = c->curstackinfo; 432 PL_curstack = PL_curstackinfo->si_stack;
291 PL_curstack = c->curstack; 433 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
292 PL_mainstack = c->mainstack; 434
435 PL_stack_base = AvARRAY(PL_curstack);
293 PL_stack_sp = c->stack_sp; 436 PL_stack_sp = PL_stack_base;
294 PL_op = c->op; 437 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295 PL_curpad = c->curpad; 438
296 PL_stack_base = c->stack_base; 439 New(50,PL_tmps_stack,64,SV*);
297 PL_stack_max = c->stack_max; 440 PL_tmps_floor = -1;
298 PL_tmps_stack = c->tmps_stack; 441 PL_tmps_ix = -1;
299 PL_tmps_floor = c->tmps_floor; 442 PL_tmps_max = 64;
300 PL_tmps_ix = c->tmps_ix; 443
301 PL_tmps_max = c->tmps_max; 444 New(54,PL_markstack,12,I32);
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr; 445 PL_markstack_ptr = PL_markstack;
304 PL_markstack_max = c->markstack_max; 446 PL_markstack_max = PL_markstack + 12;
305 PL_scopestack = c->scopestack;
306 PL_scopestack_ix = c->scopestack_ix;
307 PL_scopestack_max = c->scopestack_max;
308 PL_savestack = c->savestack;
309 PL_savestack_ix = c->savestack_ix;
310 PL_savestack_max = c->savestack_max;
311 PL_retstack = c->retstack;
312 PL_retstack_ix = c->retstack_ix;
313 PL_retstack_max = c->retstack_max;
314 PL_curcop = c->curcop;
315 447
316 { 448 SET_MARK_OFFSET;
317 dSP;
318 CV *cv;
319 449
320 /* now do the ugly restore mess */ 450 New(54,PL_scopestack,12,I32);
321 while ((cv = (CV *)POPs)) 451 PL_scopestack_ix = 0;
322 { 452 PL_scopestack_max = 12;
323 AV *padlist = (AV *)POPs;
324 453
325 put_padlist (cv); 454 New(54,PL_savestack,64,ANY);
326 CvPADLIST(cv) = padlist; 455 PL_savestack_ix = 0;
327 CvDEPTH(cv) = (I32)POPs; 456 PL_savestack_max = 64;
328 457
329#ifdef USE_THREADS 458 New(54,PL_retstack,8,OP*);
330 CvOWNER(cv) = (struct perl_thread *)POPs; 459 PL_retstack_ix = 0;
331 error does not work either 460 PL_retstack_max = 8;
332#endif
333 }
334
335 PUTBACK;
336 }
337} 461}
338 462
339/* 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 */
340STATIC void 467STATIC void
341destroy_stacks(pTHX) 468destroy_stacks(pTHX)
342{ 469{
343 /* die does this while calling POPSTACK, but I just don't see why. */
344 /* OTOH, die does not have a memleak, but we do... */
345 dounwind(-1);
346
347 /* is this ugly, I ask? */ 470 /* is this ugly, I ask? */
348 while (PL_scopestack_ix) 471 while (PL_scopestack_ix)
349 LEAVE; 472 LEAVE;
350 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
351 while (PL_curstackinfo->si_next) 478 while (PL_curstackinfo->si_next)
352 PL_curstackinfo = PL_curstackinfo->si_next; 479 PL_curstackinfo = PL_curstackinfo->si_next;
353 480
354 while (PL_curstackinfo) 481 while (PL_curstackinfo)
355 { 482 {
356 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);
357 492
358 SvREFCNT_dec(PL_curstackinfo->si_stack); 493 SvREFCNT_dec(PL_curstackinfo->si_stack);
359 Safefree(PL_curstackinfo->si_cxstack); 494 Safefree(PL_curstackinfo->si_cxstack);
360 Safefree(PL_curstackinfo); 495 Safefree(PL_curstackinfo);
361 PL_curstackinfo = p; 496 PL_curstackinfo = p;
362 } 497 }
363 498
364 if (PL_scopestack_ix != 0)
365 Perl_warner(aTHX_ WARN_INTERNAL,
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367 (long)PL_scopestack_ix);
368 if (PL_savestack_ix != 0)
369 Perl_warner(aTHX_ WARN_INTERNAL,
370 "Unbalanced saves: %ld more saves than restores\n",
371 (long)PL_savestack_ix);
372 if (PL_tmps_floor != -1)
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374 (long)PL_tmps_floor + 1);
375 /*
376 */
377 Safefree(PL_tmps_stack); 499 Safefree(PL_tmps_stack);
378 Safefree(PL_markstack); 500 Safefree(PL_markstack);
379 Safefree(PL_scopestack); 501 Safefree(PL_scopestack);
380 Safefree(PL_savestack); 502 Safefree(PL_savestack);
381 Safefree(PL_retstack); 503 Safefree(PL_retstack);
382} 504}
383 505
384#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}
385 644
386MODULE = Coro::State PACKAGE = Coro::State 645MODULE = Coro::State PACKAGE = Coro::State
387 646
388PROTOTYPES: ENABLE 647PROTOTYPES: ENABLE
389 648
390BOOT: 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
391 if (!padlist_cache) 658 if (!padlist_cache)
392 padlist_cache = newHV (); 659 padlist_cache = newHV ();
660
661 main_mainstack = PL_mainstack;
662}
393 663
394Coro::State 664Coro::State
395_newprocess(args) 665_newprocess(args)
396 SV * args 666 SV * args
397 PROTOTYPE: $ 667 PROTOTYPE: $
398 CODE: 668 CODE:
399 Coro__State coro; 669 Coro__State coro;
400 670
401 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 671 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402 croak ("Coro::State::newprocess expects an arrayref"); 672 croak ("Coro::State::_newprocess expects an arrayref");
403 673
404 New (0, coro, 1, struct coro); 674 New (0, coro, 1, struct coro);
405 675
676 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406 coro->mainstack = 0; /* actual work is done inside transfer */ 677 coro->mainstack = 0; /* actual work is done inside transfer */
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 678 coro->sptr = 0;
679 coro->ssize = 0;
408 680
409 RETVAL = coro; 681 RETVAL = coro;
410 OUTPUT: 682 OUTPUT:
411 RETVAL 683 RETVAL
412 684
413void 685void
414transfer(prev,next) 686transfer(prev, next, flags = TRANSFER_SAVE_ALL)
415 Coro::State_or_hashref prev 687 Coro::State_or_hashref prev
416 Coro::State_or_hashref next 688 Coro::State_or_hashref next
689 int flags
690 PROTOTYPE: @
417 CODE: 691 CODE:
418 692 transfer (aTHX_ prev, next, flags);
419 if (prev != next)
420 {
421 /*
422 * this could be done in newprocess which would lead to
423 * extremely elegant and fast (just SAVE/LOAD)
424 * code here, but lazy allocation of stacks has also
425 * some virtues and the overhead of the if() is nil.
426 */
427 if (next->mainstack)
428 {
429 SAVE (prev);
430 LOAD (next);
431 /* mark this state as in-use */
432 next->mainstack = 0;
433 next->tmps_ix = -2;
434 }
435 else if (next->tmps_ix == -2)
436 {
437 croak ("tried to transfer to running coroutine");
438 }
439 else
440 {
441 SAVE (prev);
442
443 /*
444 * emulate part of the perl startup here.
445 */
446 UNOP myop;
447
448 init_stacks (); /* from perl.c */
449 PL_op = (OP *)&myop;
450 /*PL_curcop = 0;*/
451 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453 SPAGAIN;
454 Zero(&myop, 1, UNOP);
455 myop.op_next = Nullop;
456 myop.op_flags = OPf_WANT_VOID;
457
458 PUSHMARK(SP);
459 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460 PUTBACK;
461 /*
462 * the next line is slightly wrong, as PL_op->op_next
463 * is actually being executed so we skip the first op.
464 * that doesn't matter, though, since it is only
465 * pp_nextstate and we never return...
466 */
467 PL_op = Perl_pp_entersub(aTHX);
468 SPAGAIN;
469
470 ENTER;
471 }
472 }
473 693
474void 694void
475DESTROY(coro) 695DESTROY(coro)
476 Coro::State coro 696 Coro::State coro
477 CODE: 697 CODE:
478 698
479 if (coro->mainstack) 699 if (coro->mainstack && coro->mainstack != main_mainstack)
480 { 700 {
481 struct coro temp; 701 struct coro temp;
482 702
483 SAVE(aTHX_ (&temp)); 703 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
484 LOAD(aTHX_ coro); 704 LOAD(aTHX_ coro);
485 705
486 destroy_stacks (); 706 destroy_stacks (aTHX);
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488 707
489 LOAD((&temp)); 708 LOAD((&temp)); /* this will get rid of defsv etc.. */
709
710 coro->mainstack = 0;
490 } 711 }
491 712
492 SvREFCNT_dec (coro->args); 713 if (coro->sptr)
714 {
715 deallocate_stack (coro);
716 coro->sptr = 0;
717 }
718
493 Safefree (coro); 719 Safefree (coro);
494 720
721void
722flush()
723 CODE:
724#ifdef MAY_FLUSH
725 flush_padlist_cache ();
726#endif
495 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