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

Diff Legend

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