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.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#if 0 5#include "libcoro/coro.c"
6# define CHK(x) (void *)0 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
7#else 29#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 30# define TRANSFER_LAZY_STACK 0x00000000
9#endif 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;
10 57
11struct 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 */
12 U8 dowarn; 70 U8 dowarn;
13 AV *defav; 71
14 72 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 73 PERL_SI *curstackinfo;
16 AV *curstack; 74 AV *curstack;
17 AV *mainstack; 75 AV *mainstack;
18 SV **stack_sp; 76 SV **stack_sp;
19 OP *op; 77 OP *op;
… …
35 I32 savestack_max; 93 I32 savestack_max;
36 OP **retstack; 94 OP **retstack;
37 I32 retstack_ix; 95 I32 retstack_ix;
38 I32 retstack_max; 96 I32 retstack_max;
39 COP *curcop; 97 COP *curcop;
98 JMPENV start_env;
99 JMPENV *top_env;
40 100
101 /* data associated with this coroutine (initial args) */
41 AV *args; 102 AV *args;
42}; 103};
43 104
44typedef struct coro *Coro__State; 105typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 106typedef struct coro *Coro__State_or_hashref;
46 107
108static AV *main_mainstack; /* used to differentiate between $main and others */
109static HV *coro_state_stash;
110static SV *ucoro_state_sv;
111static U32 ucoro_state_hash;
47static HV *padlist_cache; 112static HV *padlist_cache;
48 113
49/* mostly copied from op.c:cv_clone2 */ 114/* mostly copied from op.c:cv_clone2 */
50STATIC AV * 115STATIC AV *
51clone_padlist (AV *protopadlist) 116clone_padlist (AV *protopadlist)
… …
115 SvPADTMP_on (sv); 180 SvPADTMP_on (sv);
116 npad[ix] = sv; 181 npad[ix] = sv;
117 } 182 }
118 } 183 }
119 184
120#if 0 /* NONOTUNDERSTOOD */ 185#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 186 /* Now that vars are all in place, clone nested closures. */
122 187
123 for (ix = fpad; ix > 0; ix--) { 188 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 189 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 190 if (namesv
… …
138#endif 203#endif
139 204
140 return newpadlist; 205 return newpadlist;
141} 206}
142 207
208#ifdef MAY_FLUSH
143STATIC AV * 209STATIC AV *
144free_padlist (AV *padlist) 210free_padlist (AV *padlist)
145{ 211{
146 /* may be during global destruction */ 212 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 213 if (SvREFCNT(padlist))
… …
156 } 222 }
157 223
158 SvREFCNT_dec((SV*)padlist); 224 SvREFCNT_dec((SV*)padlist);
159 } 225 }
160} 226}
227#endif
161 228
162/* the next tow functions merely cache the padlists */ 229/* the next two functions merely cache the padlists */
163STATIC void 230STATIC void
164get_padlist (CV *cv) 231get_padlist (CV *cv)
165{ 232{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0); 233 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167 234
… …
183 } 250 }
184 251
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv)); 252 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186} 253}
187 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
188static void 289static void
189SAVE(pTHX_ Coro__State c) 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)
190{ 353{
191 { 354 {
192 dSP; 355 dSP;
193 I32 cxix = cxstack_ix; 356 I32 cxix = cxstack_ix;
357 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 358 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 359
197 /* 360 /*
198 * the worst thing you can imagine happens first - we have to save 361 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 362 * (and reinitialize) all cv's in the whole callchain :(
200 */ 363 */
201 364
202 PUSHs (Nullsv); 365 PUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 366 /* this loop was inspired by pp_caller */
204 for (;;) 367 for (;;)
205 { 368 {
206 while (cxix >= 0) 369 do
207 { 370 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 371 PERL_CONTEXT *cx = &ccstk[cxix--];
209 372
210 if (CxTYPE(cx) == CXt_SUB) 373 if (CxTYPE(cx) == CXt_SUB)
211 { 374 {
212 CV *cv = cx->blk_sub.cv; 375 CV *cv = cx->blk_sub.cv;
213 if (CvDEPTH(cv)) 376 if (CvDEPTH(cv))
214 { 377 {
215#ifdef USE_THREADS 378#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv)); 379 /*XPUSHs ((SV *)CvOWNER(cv));*/
380 /*CvOWNER(cv) = 0;*/
381 /*error must unlock this cv etc.. etc...*/
217#endif 382#endif
218 EXTEND (SP, 3); 383 EXTEND (SP, CvDEPTH(cv)*2);
384
385 while (--CvDEPTH(cv))
386 {
387 /* this tells the restore code to increment CvDEPTH */
388 PUSHs (Nullsv);
219 PUSHs ((SV *)CvDEPTH(cv)); 389 PUSHs ((SV *)cv);
390 }
391
220 PUSHs ((SV *)CvPADLIST(cv)); 392 PUSHs ((SV *)CvPADLIST(cv));
221 PUSHs ((SV *)cv); 393 PUSHs ((SV *)cv);
222 394
223 get_padlist (cv); 395 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 } 396 }
233 } 397 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 398 else if (CxTYPE(cx) == CXt_FORMAT)
235 { 399 {
236 /* I never used formats, so how should I know how these are implemented? */ 400 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */ 401 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 402 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 } 403 }
240 } 404 }
405 while (cxix >= 0);
241 406
242 if (top_si->si_type == PERLSI_MAIN) 407 if (top_si->si_type == PERLSI_MAIN)
243 break; 408 break;
244 409
245 top_si = top_si->si_prev; 410 top_si = top_si->si_prev;
… …
248 } 413 }
249 414
250 PUTBACK; 415 PUTBACK;
251 } 416 }
252 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
253 c->dowarn = PL_dowarn; 427 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv); 428
255 c->curstackinfo = PL_curstackinfo; 429 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack; 430 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack; 431 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp; 432 c->stack_sp = PL_stack_sp;
259 c->op = PL_op; 433 c->op = PL_op;
… …
275 c->savestack_max = PL_savestack_max; 449 c->savestack_max = PL_savestack_max;
276 c->retstack = PL_retstack; 450 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix; 451 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max; 452 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop; 453 c->curcop = PL_curcop;
454 c->start_env = PL_start_env;
455 c->top_env = PL_top_env;
280} 456}
281 457
282static void 458/*
283LOAD(pTHX_ Coro__State c) 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)
284{ 466{
285 PL_dowarn = c->dowarn; 467 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286 GvAV (PL_defgv) = c->defav; 468 PL_curstackinfo->si_type = PERLSI_MAIN;
287 PL_curstackinfo = c->curstackinfo; 469 PL_curstack = PL_curstackinfo->si_stack;
288 PL_curstack = c->curstack; 470 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289 PL_mainstack = c->mainstack; 471
472 PL_stack_base = AvARRAY(PL_curstack);
290 PL_stack_sp = c->stack_sp; 473 PL_stack_sp = PL_stack_base;
291 PL_op = c->op; 474 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292 PL_curpad = c->curpad; 475
293 PL_stack_base = c->stack_base; 476 New(50,PL_tmps_stack,96,SV*);
294 PL_stack_max = c->stack_max; 477 PL_tmps_floor = -1;
295 PL_tmps_stack = c->tmps_stack; 478 PL_tmps_ix = -1;
296 PL_tmps_floor = c->tmps_floor; 479 PL_tmps_max = 96;
297 PL_tmps_ix = c->tmps_ix; 480
298 PL_tmps_max = c->tmps_max; 481 New(54,PL_markstack,16,I32);
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr; 482 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 483 PL_markstack_max = PL_markstack + 16;
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 484
313 { 485 SET_MARK_OFFSET;
314 dSP;
315 CV *cv;
316 486
317 /* now do the ugly restore mess */ 487 New(54,PL_scopestack,16,I32);
318 while ((cv = (CV *)POPs)) 488 PL_scopestack_ix = 0;
319 { 489 PL_scopestack_max = 16;
320 AV *padlist = (AV *)POPs;
321 490
322 put_padlist (cv); 491 New(54,PL_savestack,96,ANY);
323 CvPADLIST(cv) = padlist; 492 PL_savestack_ix = 0;
324 CvDEPTH(cv) = (I32)POPs; 493 PL_savestack_max = 96;
325 494
326#ifdef USE_THREADS 495 New(54,PL_retstack,8,OP*);
327 CvOWNER(cv) = (struct perl_thread *)POPs; 496 PL_retstack_ix = 0;
328 error does not work either 497 PL_retstack_max = 8;
329#endif
330 }
331
332 PUTBACK;
333 }
334} 498}
335 499
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 500/*
501 * destroy the stacks, the callchain etc...
502 * still there is a memleak of 128 bytes...
503 */
337STATIC void 504STATIC void
338destroy_stacks(pTHX) 505destroy_stacks(pTHX)
339{ 506{
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? */ 507 /* is this ugly, I ask? */
346 while (PL_scopestack_ix) 508 while (PL_scopestack_ix)
347 LEAVE; 509 LEAVE;
348 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
349 while (PL_curstackinfo->si_next) 515 while (PL_curstackinfo->si_next)
350 PL_curstackinfo = PL_curstackinfo->si_next; 516 PL_curstackinfo = PL_curstackinfo->si_next;
351 517
352 while (PL_curstackinfo) 518 while (PL_curstackinfo)
353 { 519 {
354 PERL_SI *p = PL_curstackinfo->si_prev; 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);
355 529
356 SvREFCNT_dec(PL_curstackinfo->si_stack); 530 SvREFCNT_dec(PL_curstackinfo->si_stack);
357 Safefree(PL_curstackinfo->si_cxstack); 531 Safefree(PL_curstackinfo->si_cxstack);
358 Safefree(PL_curstackinfo); 532 Safefree(PL_curstackinfo);
359 PL_curstackinfo = p; 533 PL_curstackinfo = p;
360 } 534 }
361 535
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); 536 Safefree(PL_tmps_stack);
376 Safefree(PL_markstack); 537 Safefree(PL_markstack);
377 Safefree(PL_scopestack); 538 Safefree(PL_scopestack);
378 Safefree(PL_savestack); 539 Safefree(PL_savestack);
379 Safefree(PL_retstack); 540 Safefree(PL_retstack);
380} 541}
381 542
382#define SUB_INIT "Coro::State::_newcoro" 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}
383 745
384MODULE = Coro::State PACKAGE = Coro::State 746MODULE = Coro::State PACKAGE = Coro::State
385 747
386PROTOTYPES: ENABLE 748PROTOTYPES: ENABLE
387 749
388BOOT: 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
389 if (!padlist_cache) 761 if (!padlist_cache)
390 padlist_cache = newHV (); 762 padlist_cache = newHV ();
763
764 main_mainstack = PL_mainstack;
765}
391 766
392Coro::State 767Coro::State
393_newprocess(args) 768_newprocess(args)
394 SV * args 769 SV * args
395 PROTOTYPE: $ 770 PROTOTYPE: $
396 CODE: 771 CODE:
397 Coro__State coro; 772 Coro__State coro;
398 773
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 774 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400 croak ("Coro::State::newprocess expects an arrayref"); 775 croak ("Coro::State::_newprocess expects an arrayref");
401 776
402 New (0, coro, 1, struct coro); 777 New (0, coro, 1, struct coro);
403 778
779 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404 coro->mainstack = 0; /* actual work is done inside transfer */ 780 coro->mainstack = 0; /* actual work is done inside transfer */
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 781 coro->stack = 0;
406 782
407 RETVAL = coro; 783 RETVAL = coro;
408 OUTPUT: 784 OUTPUT:
409 RETVAL 785 RETVAL
410 786
411void 787void
412transfer(prev,next) 788transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
413 Coro::State_or_hashref prev 789 Coro::State_or_hashref prev
414 Coro::State_or_hashref next 790 Coro::State_or_hashref next
791 int flags
792 PROTOTYPE: @
415 CODE: 793 CODE:
416 794 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 795
467void 796void
468DESTROY(coro) 797DESTROY(coro)
469 Coro::State coro 798 Coro::State coro
470 CODE: 799 CODE:
471 800
472 if (coro->mainstack) 801 if (coro->mainstack && coro->mainstack != main_mainstack)
473 { 802 {
474 struct coro temp; 803 struct coro temp;
475 804
476 PUTBACK;
477 SAVE(aTHX_ (&temp)); 805 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
478 LOAD(aTHX_ coro); 806 LOAD(aTHX_ coro);
479 807
480 destroy_stacks (); 808 destroy_stacks (aTHX);
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482 809
483 LOAD((&temp)); 810 LOAD((&temp)); /* this will get rid of defsv etc.. */
484 SPAGAIN; 811
812 coro->mainstack = 0;
485 } 813 }
486 814
487 SvREFCNT_dec (coro->args); 815 deallocate_stack (coro);
816
488 Safefree (coro); 817 Safefree (coro);
489 818
819void
820flush()
821 CODE:
822#ifdef MAY_FLUSH
823 flush_padlist_cache ();
824#endif
490 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