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.7 by root, Thu Jul 19 02:45:09 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#if 1
6# define CHK(x) (void *)0 6# define CHK(x) (void *)0
7#else 7#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9#endif 9#endif
10 10
11#define MAY_FLUSH /* increases codesize */
12
13#define SAVE_DEFAV 0x00000001
14#define SAVE_DEFSV 0x00000002
15#define SAVE_ERRSV 0x00000004
16
17#define SAVE_ALL -1
18
11struct coro { 19struct coro {
20 /* optionally saved, might be zero */
21 AV *defav;
22 SV *defsv;
23 SV *errsv;
24
25 /* saved global state not related to stacks */
12 U8 dowarn; 26 U8 dowarn;
13 AV *defav; 27
14 28 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 29 PERL_SI *curstackinfo;
16 AV *curstack; 30 AV *curstack;
17 AV *mainstack; 31 AV *mainstack;
18 SV **stack_sp; 32 SV **stack_sp;
19 OP *op; 33 OP *op;
… …
36 OP **retstack; 50 OP **retstack;
37 I32 retstack_ix; 51 I32 retstack_ix;
38 I32 retstack_max; 52 I32 retstack_max;
39 COP *curcop; 53 COP *curcop;
40 54
55 /* data associated with this coroutine (initial args) */
41 AV *args; 56 AV *args;
42}; 57};
43 58
44typedef struct coro *Coro__State; 59typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 60typedef struct coro *Coro__State_or_hashref;
… …
115 SvPADTMP_on (sv); 130 SvPADTMP_on (sv);
116 npad[ix] = sv; 131 npad[ix] = sv;
117 } 132 }
118 } 133 }
119 134
120#if 0 /* NONOTUNDERSTOOD */ 135#if 0 /* return -ENOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */ 136 /* Now that vars are all in place, clone nested closures. */
122 137
123 for (ix = fpad; ix > 0; ix--) { 138 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 139 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv 140 if (namesv
… …
138#endif 153#endif
139 154
140 return newpadlist; 155 return newpadlist;
141} 156}
142 157
158#ifdef MAY_FLUSH
143STATIC AV * 159STATIC AV *
144free_padlist (AV *padlist) 160free_padlist (AV *padlist)
145{ 161{
146 /* may be during global destruction */ 162 /* may be during global destruction */
147 if (SvREFCNT(padlist)) 163 if (SvREFCNT(padlist))
… …
156 } 172 }
157 173
158 SvREFCNT_dec((SV*)padlist); 174 SvREFCNT_dec((SV*)padlist);
159 } 175 }
160} 176}
177#endif
161 178
162/* the next tow functions merely cache the padlists */ 179/* the next two functions merely cache the padlists */
163STATIC void 180STATIC void
164get_padlist (CV *cv) 181get_padlist (CV *cv)
165{ 182{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0); 183 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167 184
… …
183 } 200 }
184 201
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv)); 202 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186} 203}
187 204
205#ifdef MAY_FLUSH
206STATIC void
207flush_padlist_cache ()
208{
209 HV *hv = padlist_cache;
210 padlist_cache = newHV ();
211
212 if (hv_iterinit (hv))
213 {
214 HE *he;
215 AV *padlist;
216
217 while (!!(he = hv_iternext (hv)))
218 {
219 AV *av = (AV *)HeVAL(he);
220
221 /* casting is fun. */
222 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
223 free_padlist (padlist);
224 }
225 }
226
227 SvREFCNT_dec (hv);
228}
229#endif
230
231#define SB do {
232#define SE } while (0)
233
234#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE
235#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE
236
237#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
238
188static void 239static void
189SAVE(pTHX_ Coro__State c) 240load_state(pTHX_ Coro__State c)
241{
242 PL_dowarn = c->dowarn;
243
244 PL_curstackinfo = c->curstackinfo;
245 PL_curstack = c->curstack;
246 PL_mainstack = c->mainstack;
247 PL_stack_sp = c->stack_sp;
248 PL_op = c->op;
249 PL_curpad = c->curpad;
250 PL_stack_base = c->stack_base;
251 PL_stack_max = c->stack_max;
252 PL_tmps_stack = c->tmps_stack;
253 PL_tmps_floor = c->tmps_floor;
254 PL_tmps_ix = c->tmps_ix;
255 PL_tmps_max = c->tmps_max;
256 PL_markstack = c->markstack;
257 PL_markstack_ptr = c->markstack_ptr;
258 PL_markstack_max = c->markstack_max;
259 PL_scopestack = c->scopestack;
260 PL_scopestack_ix = c->scopestack_ix;
261 PL_scopestack_max = c->scopestack_max;
262 PL_savestack = c->savestack;
263 PL_savestack_ix = c->savestack_ix;
264 PL_savestack_max = c->savestack_max;
265 PL_retstack = c->retstack;
266 PL_retstack_ix = c->retstack_ix;
267 PL_retstack_max = c->retstack_max;
268 PL_curcop = c->curcop;
269
270 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
271 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
272 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
273
274 {
275 dSP;
276 CV *cv;
277
278 /* now do the ugly restore mess */
279 while ((cv = (CV *)POPs))
280 {
281 AV *padlist = (AV *)POPs;
282
283 if (padlist)
284 {
285 put_padlist (cv); /* mark this padlist as available */
286 CvPADLIST(cv) = padlist;
287#ifdef USE_THREADS
288 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
289#endif
290 }
291
292 ++CvDEPTH(cv);
293 }
294
295 PUTBACK;
296 }
297}
298
299static void
300save_state(pTHX_ Coro__State c, int flags)
190{ 301{
191 { 302 {
192 dSP; 303 dSP;
193 I32 cxix = cxstack_ix; 304 I32 cxix = cxstack_ix;
194 PERL_SI *top_si = PL_curstackinfo; 305 PERL_SI *top_si = PL_curstackinfo;
… …
201 312
202 PUSHs (Nullsv); 313 PUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 314 /* this loop was inspired by pp_caller */
204 for (;;) 315 for (;;)
205 { 316 {
206 while (cxix >= 0) 317 do
207 { 318 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 319 PERL_CONTEXT *cx = &ccstk[cxix--];
209 320
210 if (CxTYPE(cx) == CXt_SUB) 321 if (CxTYPE(cx) == CXt_SUB)
211 { 322 {
212 CV *cv = cx->blk_sub.cv; 323 CV *cv = cx->blk_sub.cv;
213 if (CvDEPTH(cv)) 324 if (CvDEPTH(cv))
214 { 325 {
215#ifdef USE_THREADS 326#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv)); 327 /*XPUSHs ((SV *)CvOWNER(cv));*/
328 /*CvOWNER(cv) = 0;*/
329 /*error must unlock this cv etc.. etc...*/
217#endif 330#endif
218 EXTEND (SP, 3); 331 EXTEND (SP, CvDEPTH(cv)*2);
332
333 while (--CvDEPTH(cv))
334 {
335 /* this tells the restore code to increment CvDEPTH */
336 PUSHs (Nullsv);
219 PUSHs ((SV *)CvDEPTH(cv)); 337 PUSHs ((SV *)cv);
338 }
339
220 PUSHs ((SV *)CvPADLIST(cv)); 340 PUSHs ((SV *)CvPADLIST(cv));
221 PUSHs ((SV *)cv); 341 PUSHs ((SV *)cv);
222 342
223 get_padlist (cv); 343 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 } 344 }
233 } 345 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 346 else if (CxTYPE(cx) == CXt_FORMAT)
235 { 347 {
236 /* I never used formats, so how should I know how these are implemented? */ 348 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */ 349 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 350 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 } 351 }
240 } 352 }
353 while (cxix >= 0);
241 354
242 if (top_si->si_type == PERLSI_MAIN) 355 if (top_si->si_type == PERLSI_MAIN)
243 break; 356 break;
244 357
245 top_si = top_si->si_prev; 358 top_si = top_si->si_prev;
… …
248 } 361 }
249 362
250 PUTBACK; 363 PUTBACK;
251 } 364 }
252 365
366 c->defav = flags & SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
367 c->defsv = flags & SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
368 c->errsv = flags & SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
369
253 c->dowarn = PL_dowarn; 370 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv); 371
255 c->curstackinfo = PL_curstackinfo; 372 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack; 373 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack; 374 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp; 375 c->stack_sp = PL_stack_sp;
259 c->op = PL_op; 376 c->op = PL_op;
… …
277 c->retstack_ix = PL_retstack_ix; 394 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max; 395 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop; 396 c->curcop = PL_curcop;
280} 397}
281 398
282static void 399/*
283LOAD(pTHX_ Coro__State c) 400 * destroy the stacks, the callchain etc...
284{ 401 * still there is a memleak of 128 bytes...
285 PL_dowarn = c->dowarn; 402 */
286 GvAV (PL_defgv) = c->defav;
287 PL_curstackinfo = c->curstackinfo;
288 PL_curstack = c->curstack;
289 PL_mainstack = c->mainstack;
290 PL_stack_sp = c->stack_sp;
291 PL_op = c->op;
292 PL_curpad = c->curpad;
293 PL_stack_base = c->stack_base;
294 PL_stack_max = c->stack_max;
295 PL_tmps_stack = c->tmps_stack;
296 PL_tmps_floor = c->tmps_floor;
297 PL_tmps_ix = c->tmps_ix;
298 PL_tmps_max = c->tmps_max;
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr;
301 PL_markstack_max = c->markstack_max;
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
313 {
314 dSP;
315 CV *cv;
316
317 /* now do the ugly restore mess */
318 while ((cv = (CV *)POPs))
319 {
320 AV *padlist = (AV *)POPs;
321
322 put_padlist (cv);
323 CvPADLIST(cv) = padlist;
324 CvDEPTH(cv) = (I32)POPs;
325
326#ifdef USE_THREADS
327 CvOWNER(cv) = (struct perl_thread *)POPs;
328 error does not work either
329#endif
330 }
331
332 PUTBACK;
333 }
334}
335
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
337STATIC void 403STATIC void
338destroy_stacks(pTHX) 404destroy_stacks(pTHX)
339{ 405{
340 /* die does this while calling POPSTACK, but I just don't see why. */
341 dounwind(-1);
342
343 /* is this ugly, I ask? */ 406 /* is this ugly, I ask? */
344 while (PL_scopestack_ix) 407 while (PL_scopestack_ix)
345 LEAVE; 408 LEAVE;
346 409
410 /* sure it is, but more important: is it correct?? :/ */
411 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
412 FREETMPS;
413
347 while (PL_curstackinfo->si_next) 414 while (PL_curstackinfo->si_next)
348 PL_curstackinfo = PL_curstackinfo->si_next; 415 PL_curstackinfo = PL_curstackinfo->si_next;
349 416
350 while (PL_curstackinfo) 417 while (PL_curstackinfo)
351 { 418 {
352 PERL_SI *p = PL_curstackinfo->si_prev; 419 PERL_SI *p = PL_curstackinfo->si_prev;
420
421 {
422 dSP;
423 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
424 PUTBACK; /* possibly superfluous */
425 }
426
427 dounwind(-1);
353 428
354 SvREFCNT_dec(PL_curstackinfo->si_stack); 429 SvREFCNT_dec(PL_curstackinfo->si_stack);
355 Safefree(PL_curstackinfo->si_cxstack); 430 Safefree(PL_curstackinfo->si_cxstack);
356 Safefree(PL_curstackinfo); 431 Safefree(PL_curstackinfo);
357 PL_curstackinfo = p; 432 PL_curstackinfo = p;
358 } 433 }
359 434
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); 435 Safefree(PL_tmps_stack);
374 Safefree(PL_markstack); 436 Safefree(PL_markstack);
375 Safefree(PL_scopestack); 437 Safefree(PL_scopestack);
376 Safefree(PL_savestack); 438 Safefree(PL_savestack);
377 Safefree(PL_retstack); 439 Safefree(PL_retstack);
… …
382MODULE = Coro::State PACKAGE = Coro::State 444MODULE = Coro::State PACKAGE = Coro::State
383 445
384PROTOTYPES: ENABLE 446PROTOTYPES: ENABLE
385 447
386BOOT: 448BOOT:
449 HV * stash = gv_stashpvn("Coro::State", 10, TRUE);
450
451 newCONSTSUB (stash, "SAVE_DEFAV", newSViv (SAVE_DEFAV));
452 newCONSTSUB (stash, "SAVE_DEFSV", newSViv (SAVE_DEFSV));
453 newCONSTSUB (stash, "SAVE_ERRSV", newSViv (SAVE_ERRSV));
454
387 if (!padlist_cache) 455 if (!padlist_cache)
388 padlist_cache = newHV (); 456 padlist_cache = newHV ();
389 457
390Coro::State 458Coro::State
391_newprocess(args) 459_newprocess(args)
… …
393 PROTOTYPE: $ 461 PROTOTYPE: $
394 CODE: 462 CODE:
395 Coro__State coro; 463 Coro__State coro;
396 464
397 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 465 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398 croak ("Coro::State::newprocess expects an arrayref"); 466 croak ("Coro::State::_newprocess expects an arrayref");
399 467
400 New (0, coro, 1, struct coro); 468 New (0, coro, 1, struct coro);
401 469
402 coro->mainstack = 0; /* actual work is done inside transfer */ 470 coro->mainstack = 0; /* actual work is done inside transfer */
403 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 471 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
… …
405 RETVAL = coro; 473 RETVAL = coro;
406 OUTPUT: 474 OUTPUT:
407 RETVAL 475 RETVAL
408 476
409void 477void
410transfer(prev,next) 478transfer(prev, next, flags = SAVE_DEFAV)
411 Coro::State_or_hashref prev 479 Coro::State_or_hashref prev
412 Coro::State_or_hashref next 480 Coro::State_or_hashref next
481 int flags
413 CODE: 482 CODE:
414 483
415 if (prev != next) 484 if (prev != next)
416 { 485 {
417 PUTBACK;
418 SAVE (aTHX_ prev);
419
420 /* 486 /*
421 * this could be done in newprocess which would lead to 487 * this could be done in newprocess which would lead to
422 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 488 * extremely elegant and fast (just SAVE/LOAD)
423 * code here, but lazy allocation of stacks has also 489 * code here, but lazy allocation of stacks has also
424 * some virtues and the overhead of the if() is nil. 490 * some virtues and the overhead of the if() is nil.
425 */ 491 */
426 if (next->mainstack) 492 if (next->mainstack)
427 { 493 {
494 SAVE (prev, flags);
428 LOAD (aTHX_ next); 495 LOAD (next);
429 next->mainstack = 0; /* unnecessary but much cleaner */ 496 /* mark this state as in-use */
430 SPAGAIN; 497 next->mainstack = 0;
498 next->tmps_ix = -2;
499 }
500 else if (next->tmps_ix == -2)
501 {
502 croak ("tried to transfer to running coroutine");
431 } 503 }
432 else 504 else
433 { 505 {
434 /* 506 /*
435 * emulate part of the perl startup here. 507 * emulate part of the perl startup here.
436 */ 508 */
437 UNOP myop; 509 UNOP myop;
438 510
511 SAVE (prev, -1); /* first get rid of the old state */
512
439 init_stacks (); /* from perl.c */ 513 init_stacks (); /* from perl.c */
514 SPAGAIN;
515
440 PL_op = (OP *)&myop; 516 PL_op = (OP *)&myop;
441 /*PL_curcop = 0;*/ 517 /*PL_curcop = 0;*/
518 SvREFCNT_dec (GvAV (PL_defgv));
442 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args); 519 GvAV (PL_defgv) = next->args;
443 520
444 SPAGAIN;
445 Zero(&myop, 1, UNOP); 521 Zero(&myop, 1, UNOP);
446 myop.op_next = Nullop; 522 myop.op_next = Nullop;
447 myop.op_flags = OPf_WANT_VOID; 523 myop.op_flags = OPf_WANT_VOID;
448 524
449 PUSHMARK(SP); 525 PUSHMARK(SP);
450 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE)); 526 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451 PUTBACK;
452 /* 527 /*
453 * the next line is slightly wrong, as PL_op->op_next 528 * the next line is slightly wrong, as PL_op->op_next
454 * is actually being executed so we skip the first op. 529 * is actually being executed so we skip the first op.
455 * that doesn't matter, though, since it is only 530 * that doesn't matter, though, since it is only
456 * pp_nextstate and we never return... 531 * pp_nextstate and we never return...
532 * ah yes, and I don't care anyways ;)
457 */ 533 */
534 PUTBACK;
458 PL_op = Perl_pp_entersub(aTHX); 535 PL_op = pp_entersub(aTHX);
459 SPAGAIN; 536 SPAGAIN;
460 537
461 ENTER; 538 ENTER; /* necessary e.g. for dounwind */
462 } 539 }
463 } 540 }
464 541
465void 542void
466DESTROY(coro) 543DESTROY(coro)
… …
469 546
470 if (coro->mainstack) 547 if (coro->mainstack)
471 { 548 {
472 struct coro temp; 549 struct coro temp;
473 550
474 PUTBACK;
475 SAVE(aTHX_ (&temp)); 551 SAVE(aTHX_ (&temp), SAVE_ALL);
476 LOAD(aTHX_ coro); 552 LOAD(aTHX_ coro);
477 553
478 destroy_stacks (); 554 destroy_stacks ();
479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480 555
481 LOAD((&temp)); 556 LOAD((&temp)); /* this will get rid of defsv etc.. */
482 SPAGAIN;
483 } 557 }
484 558
485 SvREFCNT_dec (coro->args);
486 Safefree (coro); 559 Safefree (coro);
487 560
561void
562flush()
563 CODE:
564#ifdef MAY_FLUSH
565 flush_padlist_cache ();
566#endif
488 567
568

Diff Legend

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