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

Diff Legend

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