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.2 by root, Sun Jul 15 02:35:52 2001 UTC vs.
Revision 1.12 by root, Sun Jul 22 03:24:10 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 1
6# define CHK(x) (void *)0
7#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9#endif
10
11#define MAY_FLUSH /* increases codesize */
12
13#define SUB_INIT "Coro::State::initialize"
14
15#define TRANSFER_SAVE_DEFAV 0x00000001
16#define TRANSFER_SAVE_DEFSV 0x00000002
17#define TRANSFER_SAVE_ERRSV 0x00000004
18
19#define TRANSFER_SAVE_ALL -1
20
5struct coro { 21struct coro {
22 /* optionally saved, might be zero */
23 AV *defav;
24 SV *defsv;
25 SV *errsv;
26
27 /* saved global state not related to stacks */
6 U8 dowarn; 28 U8 dowarn;
7 29
30 /* the stacks and related info (callchain etc..) */
8 PERL_SI *curstackinfo; 31 PERL_SI *curstackinfo;
9 AV *curstack; 32 AV *curstack;
10 AV *mainstack; 33 AV *mainstack;
11 SV **stack_sp; 34 SV **stack_sp;
12 OP *op; 35 OP *op;
… …
29 OP **retstack; 52 OP **retstack;
30 I32 retstack_ix; 53 I32 retstack_ix;
31 I32 retstack_max; 54 I32 retstack_max;
32 COP *curcop; 55 COP *curcop;
33 56
34 AV *defav; 57 /* data associated with this coroutine (initial args) */
35 58 AV *args;
36 SV *proc;
37}; 59};
38 60
39typedef struct coro *Coro__State; 61typedef struct coro *Coro__State;
40typedef struct coro *Coro__State_or_hashref; 62typedef struct coro *Coro__State_or_hashref;
41 63
42#define SAVE(c) \ 64static AV *main_mainstack; /* used to differentiate between $main and others */
43 c->dowarn = PL_dowarn; \
44 c->curstackinfo = PL_curstackinfo; \
45 c->curstack = PL_curstack; \
46 c->mainstack = PL_mainstack; \
47 c->stack_sp = PL_stack_sp; \
48 c->op = PL_op; \
49 c->curpad = PL_curpad; \
50 c->stack_base = PL_stack_base; \
51 c->stack_max = PL_stack_max; \
52 c->tmps_stack = PL_tmps_stack; \
53 c->tmps_floor = PL_tmps_floor; \
54 c->tmps_ix = PL_tmps_ix; \
55 c->tmps_max = PL_tmps_max; \
56 c->markstack = PL_markstack; \
57 c->markstack_ptr = PL_markstack_ptr; \
58 c->markstack_max = PL_markstack_max; \
59 c->scopestack = PL_scopestack; \
60 c->scopestack_ix = PL_scopestack_ix; \
61 c->scopestack_max = PL_scopestack_max;\
62 c->savestack = PL_savestack; \
63 c->savestack_ix = PL_savestack_ix; \
64 c->savestack_max = PL_savestack_max; \
65 c->retstack = PL_retstack; \
66 c->retstack_ix = PL_retstack_ix; \
67 c->retstack_max = PL_retstack_max; \
68 c->curcop = PL_curcop; \
69 c->defav = GvAV (PL_defgv);
70 65
71#define LOAD(c) \ 66static HV *padlist_cache;
72 PL_dowarn = c->dowarn; \
73 PL_curstackinfo = c->curstackinfo; \
74 PL_curstack = c->curstack; \
75 PL_mainstack = c->mainstack; \
76 PL_stack_sp = c->stack_sp; \
77 PL_op = c->op; \
78 PL_curpad = c->curpad; \
79 PL_stack_base = c->stack_base; \
80 PL_stack_max = c->stack_max; \
81 PL_tmps_stack = c->tmps_stack; \
82 PL_tmps_floor = c->tmps_floor; \
83 PL_tmps_ix = c->tmps_ix; \
84 PL_tmps_max = c->tmps_max; \
85 PL_markstack = c->markstack; \
86 PL_markstack_ptr = c->markstack_ptr; \
87 PL_markstack_max = c->markstack_max; \
88 PL_scopestack = c->scopestack; \
89 PL_scopestack_ix = c->scopestack_ix; \
90 PL_scopestack_max = c->scopestack_max;\
91 PL_savestack = c->savestack; \
92 PL_savestack_ix = c->savestack_ix; \
93 PL_savestack_max = c->savestack_max; \
94 PL_retstack = c->retstack; \
95 PL_retstack_ix = c->retstack_ix; \
96 PL_retstack_max = c->retstack_max; \
97 PL_curcop = c->curcop; \
98 GvAV (PL_defgv) = c->defav;
99 67
100/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 68/* mostly copied from op.c:cv_clone2 */
69STATIC AV *
70clone_padlist (AV *protopadlist)
71{
72 AV *av;
73 I32 ix;
74 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
75 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
76 SV **pname = AvARRAY (protopad_name);
77 SV **ppad = AvARRAY (protopad);
78 I32 fname = AvFILLp (protopad_name);
79 I32 fpad = AvFILLp (protopad);
80 AV *newpadlist, *newpad_name, *newpad;
81 SV **npad;
82
83 newpad_name = newAV ();
84 for (ix = fname; ix >= 0; ix--)
85 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
86
87 newpad = newAV ();
88 av_fill (newpad, AvFILLp (protopad));
89 npad = AvARRAY (newpad);
90
91 newpadlist = newAV ();
92 AvREAL_off (newpadlist);
93 av_store (newpadlist, 0, (SV *) newpad_name);
94 av_store (newpadlist, 1, (SV *) newpad);
95
96 av = newAV (); /* will be @_ */
97 av_extend (av, 0);
98 av_store (newpad, 0, (SV *) av);
99 AvFLAGS (av) = AVf_REIFY;
100
101 for (ix = fpad; ix > 0; ix--)
102 {
103 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
104 if (namesv && namesv != &PL_sv_undef)
105 {
106 char *name = SvPVX (namesv); /* XXX */
107 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')
108 { /* lexical from outside? */
109 npad[ix] = SvREFCNT_inc (ppad[ix]);
110 }
111 else
112 { /* our own lexical */
113 SV *sv;
114 if (*name == '&')
115 sv = SvREFCNT_inc (ppad[ix]);
116 else if (*name == '@')
117 sv = (SV *) newAV ();
118 else if (*name == '%')
119 sv = (SV *) newHV ();
120 else
121 sv = NEWSV (0, 0);
122 if (!SvPADBUSY (sv))
123 SvPADMY_on (sv);
124 npad[ix] = sv;
125 }
126 }
127 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
128 {
129 npad[ix] = SvREFCNT_inc (ppad[ix]);
130 }
131 else
132 {
133 SV *sv = NEWSV (0, 0);
134 SvPADTMP_on (sv);
135 npad[ix] = sv;
136 }
137 }
138
139#if 0 /* return -ENOTUNDERSTOOD */
140 /* Now that vars are all in place, clone nested closures. */
141
142 for (ix = fpad; ix > 0; ix--) {
143 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
144 if (namesv
145 && namesv != &PL_sv_undef
146 && !(SvFLAGS(namesv) & SVf_FAKE)
147 && *SvPVX(namesv) == '&'
148 && CvCLONE(ppad[ix]))
149 {
150 CV *kid = cv_clone((CV*)ppad[ix]);
151 SvREFCNT_dec(ppad[ix]);
152 CvCLONE_on(kid);
153 SvPADMY_on(kid);
154 npad[ix] = (SV*)kid;
155 }
156 }
157#endif
158
159 return newpadlist;
160}
161
162#ifdef MAY_FLUSH
163STATIC AV *
164free_padlist (AV *padlist)
165{
166 /* may be during global destruction */
167 if (SvREFCNT(padlist))
168 {
169 I32 i = AvFILLp(padlist);
170 while (i >= 0)
171 {
172 SV **svp = av_fetch(padlist, i--, FALSE);
173 SV *sv = svp ? *svp : Nullsv;
174 if (sv)
175 SvREFCNT_dec(sv);
176 }
177
178 SvREFCNT_dec((SV*)padlist);
179 }
180}
181#endif
182
183/* the next two functions merely cache the padlists */
101STATIC void 184STATIC void
102S_nuke_stacks(pTHX) 185get_padlist (CV *cv)
103{ 186{
104 while (PL_curstackinfo->si_next) 187 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
105 PL_curstackinfo = PL_curstackinfo->si_next; 188
106 while (PL_curstackinfo) { 189 if (he && AvFILLp ((AV *)*he) >= 0)
107 PERL_SI *p = PL_curstackinfo->si_prev; 190 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
108 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 191 else
109 Safefree(PL_curstackinfo->si_cxstack); 192 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
110 Safefree(PL_curstackinfo); 193}
111 PL_curstackinfo = p; 194
195STATIC void
196put_padlist (CV *cv)
197{
198 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
199
200 if (SvTYPE (*he) != SVt_PVAV)
201 {
202 SvREFCNT_dec (*he);
203 *he = (SV *)newAV ();
112 } 204 }
205
206 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
207}
208
209#ifdef MAY_FLUSH
210STATIC void
211flush_padlist_cache ()
212{
213 HV *hv = padlist_cache;
214 padlist_cache = newHV ();
215
216 if (hv_iterinit (hv))
217 {
218 HE *he;
219 AV *padlist;
220
221 while (!!(he = hv_iternext (hv)))
222 {
223 AV *av = (AV *)HeVAL(he);
224
225 /* casting is fun. */
226 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
227 free_padlist (padlist);
228 }
229 }
230
231 SvREFCNT_dec (hv);
232}
233#endif
234
235#define SB do {
236#define SE } while (0)
237
238#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE
239#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE
240
241#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
242
243static void
244load_state(pTHX_ Coro__State c)
245{
246 PL_dowarn = c->dowarn;
247
248 PL_curstackinfo = c->curstackinfo;
249 PL_curstack = c->curstack;
250 PL_mainstack = c->mainstack;
251 PL_stack_sp = c->stack_sp;
252 PL_op = c->op;
253 PL_curpad = c->curpad;
254 PL_stack_base = c->stack_base;
255 PL_stack_max = c->stack_max;
256 PL_tmps_stack = c->tmps_stack;
257 PL_tmps_floor = c->tmps_floor;
258 PL_tmps_ix = c->tmps_ix;
259 PL_tmps_max = c->tmps_max;
260 PL_markstack = c->markstack;
261 PL_markstack_ptr = c->markstack_ptr;
262 PL_markstack_max = c->markstack_max;
263 PL_scopestack = c->scopestack;
264 PL_scopestack_ix = c->scopestack_ix;
265 PL_scopestack_max = c->scopestack_max;
266 PL_savestack = c->savestack;
267 PL_savestack_ix = c->savestack_ix;
268 PL_savestack_max = c->savestack_max;
269 PL_retstack = c->retstack;
270 PL_retstack_ix = c->retstack_ix;
271 PL_retstack_max = c->retstack_max;
272 PL_curcop = c->curcop;
273
274 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
275 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
276 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
277
278 {
279 dSP;
280 CV *cv;
281
282 /* now do the ugly restore mess */
283 while ((cv = (CV *)POPs))
284 {
285 AV *padlist = (AV *)POPs;
286
287 if (padlist)
288 {
289 put_padlist (cv); /* mark this padlist as available */
290 CvPADLIST(cv) = padlist;
291#ifdef USE_THREADS
292 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
293#endif
294 }
295
296 ++CvDEPTH(cv);
297 }
298
299 PUTBACK;
300 }
301}
302
303static void
304save_state(pTHX_ Coro__State c, int flags)
305{
306 {
307 dSP;
308 I32 cxix = cxstack_ix;
309 PERL_CONTEXT *ccstk = cxstack;
310 PERL_SI *top_si = PL_curstackinfo;
311
312 /*
313 * the worst thing you can imagine happens first - we have to save
314 * (and reinitialize) all cv's in the whole callchain :(
315 */
316
317 PUSHs (Nullsv);
318 /* this loop was inspired by pp_caller */
319 for (;;)
320 {
321 do
322 {
323 PERL_CONTEXT *cx = &ccstk[cxix--];
324
325 if (CxTYPE(cx) == CXt_SUB)
326 {
327 CV *cv = cx->blk_sub.cv;
328 if (CvDEPTH(cv))
329 {
330#ifdef USE_THREADS
331 /*XPUSHs ((SV *)CvOWNER(cv));*/
332 /*CvOWNER(cv) = 0;*/
333 /*error must unlock this cv etc.. etc...*/
334#endif
335 EXTEND (SP, CvDEPTH(cv)*2);
336
337 while (--CvDEPTH(cv))
338 {
339 /* this tells the restore code to increment CvDEPTH */
340 PUSHs (Nullsv);
341 PUSHs ((SV *)cv);
342 }
343
344 PUSHs ((SV *)CvPADLIST(cv));
345 PUSHs ((SV *)cv);
346
347 get_padlist (cv); /* this is a monster */
348 }
349 }
350 else if (CxTYPE(cx) == CXt_FORMAT)
351 {
352 /* I never used formats, so how should I know how these are implemented? */
353 /* my bold guess is as a simple, plain sub... */
354 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
355 }
356 }
357 while (cxix >= 0);
358
359 if (top_si->si_type == PERLSI_MAIN)
360 break;
361
362 top_si = top_si->si_prev;
363 ccstk = top_si->si_cxstack;
364 cxix = top_si->si_cxix;
365 }
366
367 PUTBACK;
368 }
369
370 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
371 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
372 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
373
374 /* I have not the slightest idea of why av_reify is necessary */
375 /* but if it's missing the defav contents magically get replaced sometimes */
376 if (c->defav)
377 av_reify (c->defav);
378
379 c->dowarn = PL_dowarn;
380
381 c->curstackinfo = PL_curstackinfo;
382 c->curstack = PL_curstack;
383 c->mainstack = PL_mainstack;
384 c->stack_sp = PL_stack_sp;
385 c->op = PL_op;
386 c->curpad = PL_curpad;
387 c->stack_base = PL_stack_base;
388 c->stack_max = PL_stack_max;
389 c->tmps_stack = PL_tmps_stack;
390 c->tmps_floor = PL_tmps_floor;
391 c->tmps_ix = PL_tmps_ix;
392 c->tmps_max = PL_tmps_max;
393 c->markstack = PL_markstack;
394 c->markstack_ptr = PL_markstack_ptr;
395 c->markstack_max = PL_markstack_max;
396 c->scopestack = PL_scopestack;
397 c->scopestack_ix = PL_scopestack_ix;
398 c->scopestack_max = PL_scopestack_max;
399 c->savestack = PL_savestack;
400 c->savestack_ix = PL_savestack_ix;
401 c->savestack_max = PL_savestack_max;
402 c->retstack = PL_retstack;
403 c->retstack_ix = PL_retstack_ix;
404 c->retstack_max = PL_retstack_max;
405 c->curcop = PL_curcop;
406}
407
408/*
409 * destroy the stacks, the callchain etc...
410 * still there is a memleak of 128 bytes...
411 */
412STATIC void
413destroy_stacks(pTHX)
414{
415 /* is this ugly, I ask? */
416 while (PL_scopestack_ix)
417 LEAVE;
418
419 /* sure it is, but more important: is it correct?? :/ */
420 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
421 FREETMPS;
422
423 while (PL_curstackinfo->si_next)
424 PL_curstackinfo = PL_curstackinfo->si_next;
425
426 while (PL_curstackinfo)
427 {
428 PERL_SI *p = PL_curstackinfo->si_prev;
429
430 {
431 dSP;
432 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
433 PUTBACK; /* possibly superfluous */
434 }
435
436 dounwind(-1);
437
438 SvREFCNT_dec(PL_curstackinfo->si_stack);
439 Safefree(PL_curstackinfo->si_cxstack);
440 Safefree(PL_curstackinfo);
441 PL_curstackinfo = p;
442 }
443
113 Safefree(PL_tmps_stack); 444 Safefree(PL_tmps_stack);
114 Safefree(PL_markstack); 445 Safefree(PL_markstack);
115 Safefree(PL_scopestack); 446 Safefree(PL_scopestack);
116 Safefree(PL_savestack); 447 Safefree(PL_savestack);
117 Safefree(PL_retstack); 448 Safefree(PL_retstack);
118} 449}
119 450
451STATIC void
452transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
453{
454 dSP;
455
456 if (prev != next)
457 {
458 /*
459 * this could be done in newprocess which would lead to
460 * extremely elegant and fast (just SAVE/LOAD)
461 * code here, but lazy allocation of stacks has also
462 * some virtues and the overhead of the if() is nil.
463 */
464 if (next->mainstack)
465 {
466 SAVE (prev, flags);
467 LOAD (next);
468 /* mark this state as in-use */
469 next->mainstack = 0;
470 next->tmps_ix = -2;
471 }
472 else if (next->tmps_ix == -2)
473 {
474 croak ("tried to transfer to running coroutine");
475 }
476 else
477 {
478 /*
479 * emulate part of the perl startup here.
480 */
481 UNOP myop;
482
483 SAVE (prev, -1); /* first get rid of the old state */
484
485 init_stacks (); /* from perl.c */
486 SPAGAIN;
487
488 PL_op = (OP *)&myop;
489 /*PL_curcop = 0;*/
490 SvREFCNT_dec (GvAV (PL_defgv));
491 GvAV (PL_defgv) = next->args;
492
493 Zero(&myop, 1, UNOP);
494 myop.op_next = Nullop;
495 myop.op_flags = OPf_WANT_VOID;
496
497 PUSHMARK(SP);
498 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
499 /*
500 * the next line is slightly wrong, as PL_op->op_next
501 * is actually being executed so we skip the first op.
502 * that doesn't matter, though, since it is only
503 * pp_nextstate and we never return...
504 * ah yes, and I don't care anyways ;)
505 */
506 PUTBACK;
507 PL_op = pp_entersub(aTHX);
508 SPAGAIN;
509
510 ENTER; /* necessary e.g. for dounwind */
511 }
512 }
513}
514
120MODULE = Coro::State PACKAGE = Coro::State 515MODULE = Coro::State PACKAGE = Coro::State
121 516
122PROTOTYPES: ENABLE 517PROTOTYPES: ENABLE
123 518
519BOOT:
520{ /* {} necessary for stoopid perl-5.6.x */
521 HV * stash = gv_stashpvn("Coro::State", 10, TRUE);
522
523 newCONSTSUB (stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
524 newCONSTSUB (stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
525 newCONSTSUB (stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
526
527 if (!padlist_cache)
528 padlist_cache = newHV ();
529
530 main_mainstack = PL_mainstack;
531}
532
124Coro::State 533Coro::State
125newprocess(proc) 534_newprocess(args)
126 SV * proc 535 SV * args
127 PROTOTYPE: & 536 PROTOTYPE: $
128 CODE: 537 CODE:
129 Coro__State coro; 538 Coro__State coro;
539
540 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
541 croak ("Coro::State::_newprocess expects an arrayref");
130 542
131 New (0, coro, 1, struct coro); 543 New (0, coro, 1, struct coro);
132 544
133 coro->mainstack = 0; /* actual work is done inside transfer */ 545 coro->mainstack = 0; /* actual work is done inside transfer */
134 coro->proc = SvREFCNT_inc (proc); 546 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
135 547
136 RETVAL = coro; 548 RETVAL = coro;
137 OUTPUT: 549 OUTPUT:
138 RETVAL 550 RETVAL
139 551
140void 552void
141transfer(prev,next) 553transfer(prev, next, flags = TRANSFER_SAVE_ALL)
142 Coro::State_or_hashref prev 554 Coro::State_or_hashref prev
143 Coro::State_or_hashref next 555 Coro::State_or_hashref next
556 int flags
557 PROTOTYPE: @
144 CODE: 558 CODE:
145 559
146 if (prev != next) 560 transfer (aTHX_ prev, next, flags);
147 {
148 PUTBACK;
149 SAVE (prev);
150
151 /*
152 * this could be done in newprocess which would to
153 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
154 * code here, but lazy allocation of stacks has also
155 * some virtues and the overhead of the if() is nil.
156 */
157 if (next->mainstack)
158 {
159 LOAD (next);
160 next->mainstack = 0; /* unnecessary but much cleaner */
161 SPAGAIN;
162 }
163 else
164 {
165 /*
166 * emulate part of the perl startup here.
167 */
168 UNOP myop;
169
170 init_stacks ();
171 PL_op = (OP *)&myop;
172 /*PL_curcop = 0;*/
173 GvAV (PL_defgv) = newAV ();
174
175 SPAGAIN;
176 Zero(&myop, 1, UNOP);
177 myop.op_next = Nullop;
178 myop.op_flags = OPf_WANT_VOID;
179
180 EXTEND (SP,1);
181 PUSHs (next->proc);
182
183 PUTBACK;
184 /*
185 * the next line is slightly wrong, as PL_op->op_next
186 * is actually being executed so we skip the first op
187 * that doens't matter, though, since it is only
188 * pp_nextstate and we never return...
189 */
190 PL_op = Perl_pp_entersub(aTHX);
191 SPAGAIN;
192
193 ENTER;
194 }
195 }
196 561
197void 562void
198DESTROY(coro) 563DESTROY(coro)
199 Coro::State coro 564 Coro::State coro
200 CODE: 565 CODE:
201 566
202 if (coro->mainstack) 567 if (coro->mainstack && coro->mainstack != main_mainstack)
203 { 568 {
204 struct coro temp; 569 struct coro temp;
205 570
206 PUTBACK; 571 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
207 SAVE((&temp));
208 LOAD(coro); 572 LOAD(aTHX_ coro);
209 573
210 S_nuke_stacks (); 574 destroy_stacks ();
211 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
212 575
213 LOAD((&temp)); 576 LOAD((&temp)); /* this will get rid of defsv etc.. */
214 SPAGAIN;
215 } 577 }
216 578
217 SvREFCNT_dec (coro->proc);
218 Safefree (coro); 579 Safefree (coro);
219 580
581 /*
582 * there is one problematic case left (remember _recurse?)
583 * consider the case when we
584 *
585 * 1. start a coroutine
586 * 2. inside it descend into some xs functions
587 * 3. xs function calls a callback
588 * 4. callback switches to $main
589 * 5. $main ends - we will end inside the xs function
590 * 6. xs function returns and perl executes - what?
591 *
592 * to avoid this case we recurse in this function
593 * and simply call my_exit(0), skipping other xs functions
594 */
220 595
596#if 0
597void
598_recurse()
599 CODE:
600 LEAVE;
601 PL_stack_sp = PL_stack_base + ax - 1;
602 PL_op = PL_op->op_next;
603 CALLRUNOPS(aTHX);
604 printf ("my_exit\n");
605 my_exit (0);
606
607#endif
608
609void
610flush()
611 CODE:
612#ifdef MAY_FLUSH
613 flush_padlist_cache ();
614#endif
615
616MODULE = Coro::State PACKAGE = Coro::Cont
617
618# this is dirty (do you hear me?) and should be in it's own .xs
619
620void
621result(...)
622 PROTOTYPE: @
623 CODE:
624 static SV *returnstk;
625 SV *sv;
626 AV *defav = GvAV (PL_defgv);
627 struct coro *prev, *next;
628
629 if (!returnstk)
630 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
631
632 /* set up @_ -- ugly */
633 av_clear (defav);
634 av_fill (defav, items - 1);
635 while (items--)
636 av_store (defav, items, SvREFCNT_inc (ST(items)));
637
638 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
639 sv = av_pop ((AV *)SvRV (returnstk));
640 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
641 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
642 SvREFCNT_dec (sv);
643 transfer(prev, next, 0);
644

Diff Legend

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