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.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 /* die does this while calling POPSTACK, but I just don't see why. */
341 dounwind(-1);
342
343 /* is this ugly, I ask? */ 507 /* is this ugly, I ask? */
344 while (PL_scopestack_ix) 508 while (PL_scopestack_ix)
345 LEAVE; 509 LEAVE;
346 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
347 while (PL_curstackinfo->si_next) 515 while (PL_curstackinfo->si_next)
348 PL_curstackinfo = PL_curstackinfo->si_next; 516 PL_curstackinfo = PL_curstackinfo->si_next;
349 517
350 while (PL_curstackinfo) 518 while (PL_curstackinfo)
351 { 519 {
352 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);
353 529
354 SvREFCNT_dec(PL_curstackinfo->si_stack); 530 SvREFCNT_dec(PL_curstackinfo->si_stack);
355 Safefree(PL_curstackinfo->si_cxstack); 531 Safefree(PL_curstackinfo->si_cxstack);
356 Safefree(PL_curstackinfo); 532 Safefree(PL_curstackinfo);
357 PL_curstackinfo = p; 533 PL_curstackinfo = p;
358 } 534 }
359 535
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); 536 Safefree(PL_tmps_stack);
374 Safefree(PL_markstack); 537 Safefree(PL_markstack);
375 Safefree(PL_scopestack); 538 Safefree(PL_scopestack);
376 Safefree(PL_savestack); 539 Safefree(PL_savestack);
377 Safefree(PL_retstack); 540 Safefree(PL_retstack);
378} 541}
379 542
380#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}
381 745
382MODULE = Coro::State PACKAGE = Coro::State 746MODULE = Coro::State PACKAGE = Coro::State
383 747
384PROTOTYPES: ENABLE 748PROTOTYPES: ENABLE
385 749
386BOOT: 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
387 if (!padlist_cache) 761 if (!padlist_cache)
388 padlist_cache = newHV (); 762 padlist_cache = newHV ();
763
764 main_mainstack = PL_mainstack;
765}
389 766
390Coro::State 767Coro::State
391_newprocess(args) 768_newprocess(args)
392 SV * args 769 SV * args
393 PROTOTYPE: $ 770 PROTOTYPE: $
394 CODE: 771 CODE:
395 Coro__State coro; 772 Coro__State coro;
396 773
397 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 774 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398 croak ("Coro::State::newprocess expects an arrayref"); 775 croak ("Coro::State::_newprocess expects an arrayref");
399 776
400 New (0, coro, 1, struct coro); 777 New (0, coro, 1, struct coro);
401 778
779 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402 coro->mainstack = 0; /* actual work is done inside transfer */ 780 coro->mainstack = 0; /* actual work is done inside transfer */
403 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 781 coro->stack = 0;
404 782
405 RETVAL = coro; 783 RETVAL = coro;
406 OUTPUT: 784 OUTPUT:
407 RETVAL 785 RETVAL
408 786
409void 787void
410transfer(prev,next) 788transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
411 Coro::State_or_hashref prev 789 Coro::State_or_hashref prev
412 Coro::State_or_hashref next 790 Coro::State_or_hashref next
791 int flags
792 PROTOTYPE: @
413 CODE: 793 CODE:
414 794 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 795
465void 796void
466DESTROY(coro) 797DESTROY(coro)
467 Coro::State coro 798 Coro::State coro
468 CODE: 799 CODE:
469 800
470 if (coro->mainstack) 801 if (coro->mainstack && coro->mainstack != main_mainstack)
471 { 802 {
472 struct coro temp; 803 struct coro temp;
473 804
474 PUTBACK;
475 SAVE(aTHX_ (&temp)); 805 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476 LOAD(aTHX_ coro); 806 LOAD(aTHX_ coro);
477 807
478 destroy_stacks (); 808 destroy_stacks (aTHX);
479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480 809
481 LOAD((&temp)); 810 LOAD((&temp)); /* this will get rid of defsv etc.. */
482 SPAGAIN; 811
812 coro->mainstack = 0;
483 } 813 }
484 814
485 SvREFCNT_dec (coro->args); 815 deallocate_stack (coro);
816
486 Safefree (coro); 817 Safefree (coro);
487 818
819void
820flush()
821 CODE:
822#ifdef MAY_FLUSH
823 flush_padlist_cache ();
824#endif
488 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