ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro/State.xs
Revision: 1.7
Committed: Thu Jul 19 02:45:09 2001 UTC (22 years, 10 months ago) by root
Branch: MAIN
Changes since 1.6: +181 -108 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
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 SAVE_DEFAV 0x00000001
14 #define SAVE_DEFSV 0x00000002
15 #define SAVE_ERRSV 0x00000004
16
17 #define SAVE_ALL -1
18
19 struct 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 */
26 U8 dowarn;
27
28 /* the stacks and related info (callchain etc..) */
29 PERL_SI *curstackinfo;
30 AV *curstack;
31 AV *mainstack;
32 SV **stack_sp;
33 OP *op;
34 SV **curpad;
35 SV **stack_base;
36 SV **stack_max;
37 SV **tmps_stack;
38 I32 tmps_floor;
39 I32 tmps_ix;
40 I32 tmps_max;
41 I32 *markstack;
42 I32 *markstack_ptr;
43 I32 *markstack_max;
44 I32 *scopestack;
45 I32 scopestack_ix;
46 I32 scopestack_max;
47 ANY *savestack;
48 I32 savestack_ix;
49 I32 savestack_max;
50 OP **retstack;
51 I32 retstack_ix;
52 I32 retstack_max;
53 COP *curcop;
54
55 /* data associated with this coroutine (initial args) */
56 AV *args;
57 };
58
59 typedef struct coro *Coro__State;
60 typedef struct coro *Coro__State_or_hashref;
61
62 static HV *padlist_cache;
63
64 /* mostly copied from op.c:cv_clone2 */
65 STATIC AV *
66 clone_padlist (AV *protopadlist)
67 {
68 AV *av;
69 I32 ix;
70 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
71 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
72 SV **pname = AvARRAY (protopad_name);
73 SV **ppad = AvARRAY (protopad);
74 I32 fname = AvFILLp (protopad_name);
75 I32 fpad = AvFILLp (protopad);
76 AV *newpadlist, *newpad_name, *newpad;
77 SV **npad;
78
79 newpad_name = newAV ();
80 for (ix = fname; ix >= 0; ix--)
81 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
82
83 newpad = newAV ();
84 av_fill (newpad, AvFILLp (protopad));
85 npad = AvARRAY (newpad);
86
87 newpadlist = newAV ();
88 AvREAL_off (newpadlist);
89 av_store (newpadlist, 0, (SV *) newpad_name);
90 av_store (newpadlist, 1, (SV *) newpad);
91
92 av = newAV (); /* will be @_ */
93 av_extend (av, 0);
94 av_store (newpad, 0, (SV *) av);
95 AvFLAGS (av) = AVf_REIFY;
96
97 for (ix = fpad; ix > 0; ix--)
98 {
99 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
100 if (namesv && namesv != &PL_sv_undef)
101 {
102 char *name = SvPVX (namesv); /* XXX */
103 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')
104 { /* lexical from outside? */
105 npad[ix] = SvREFCNT_inc (ppad[ix]);
106 }
107 else
108 { /* our own lexical */
109 SV *sv;
110 if (*name == '&')
111 sv = SvREFCNT_inc (ppad[ix]);
112 else if (*name == '@')
113 sv = (SV *) newAV ();
114 else if (*name == '%')
115 sv = (SV *) newHV ();
116 else
117 sv = NEWSV (0, 0);
118 if (!SvPADBUSY (sv))
119 SvPADMY_on (sv);
120 npad[ix] = sv;
121 }
122 }
123 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
124 {
125 npad[ix] = SvREFCNT_inc (ppad[ix]);
126 }
127 else
128 {
129 SV *sv = NEWSV (0, 0);
130 SvPADTMP_on (sv);
131 npad[ix] = sv;
132 }
133 }
134
135 #if 0 /* return -ENOTUNDERSTOOD */
136 /* Now that vars are all in place, clone nested closures. */
137
138 for (ix = fpad; ix > 0; ix--) {
139 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
140 if (namesv
141 && namesv != &PL_sv_undef
142 && !(SvFLAGS(namesv) & SVf_FAKE)
143 && *SvPVX(namesv) == '&'
144 && CvCLONE(ppad[ix]))
145 {
146 CV *kid = cv_clone((CV*)ppad[ix]);
147 SvREFCNT_dec(ppad[ix]);
148 CvCLONE_on(kid);
149 SvPADMY_on(kid);
150 npad[ix] = (SV*)kid;
151 }
152 }
153 #endif
154
155 return newpadlist;
156 }
157
158 #ifdef MAY_FLUSH
159 STATIC AV *
160 free_padlist (AV *padlist)
161 {
162 /* may be during global destruction */
163 if (SvREFCNT(padlist))
164 {
165 I32 i = AvFILLp(padlist);
166 while (i >= 0)
167 {
168 SV **svp = av_fetch(padlist, i--, FALSE);
169 SV *sv = svp ? *svp : Nullsv;
170 if (sv)
171 SvREFCNT_dec(sv);
172 }
173
174 SvREFCNT_dec((SV*)padlist);
175 }
176 }
177 #endif
178
179 /* the next two functions merely cache the padlists */
180 STATIC void
181 get_padlist (CV *cv)
182 {
183 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
184
185 if (he && AvFILLp ((AV *)*he) >= 0)
186 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
187 else
188 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
189 }
190
191 STATIC void
192 put_padlist (CV *cv)
193 {
194 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
195
196 if (SvTYPE (*he) != SVt_PVAV)
197 {
198 SvREFCNT_dec (*he);
199 *he = (SV *)newAV ();
200 }
201
202 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
203 }
204
205 #ifdef MAY_FLUSH
206 STATIC void
207 flush_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
239 static void
240 load_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
299 static void
300 save_state(pTHX_ Coro__State c, int flags)
301 {
302 {
303 dSP;
304 I32 cxix = cxstack_ix;
305 PERL_SI *top_si = PL_curstackinfo;
306 PERL_CONTEXT *ccstk = cxstack;
307
308 /*
309 * the worst thing you can imagine happens first - we have to save
310 * (and reinitialize) all cv's in the whole callchain :(
311 */
312
313 PUSHs (Nullsv);
314 /* this loop was inspired by pp_caller */
315 for (;;)
316 {
317 do
318 {
319 PERL_CONTEXT *cx = &ccstk[cxix--];
320
321 if (CxTYPE(cx) == CXt_SUB)
322 {
323 CV *cv = cx->blk_sub.cv;
324 if (CvDEPTH(cv))
325 {
326 #ifdef USE_THREADS
327 /*XPUSHs ((SV *)CvOWNER(cv));*/
328 /*CvOWNER(cv) = 0;*/
329 /*error must unlock this cv etc.. etc...*/
330 #endif
331 EXTEND (SP, CvDEPTH(cv)*2);
332
333 while (--CvDEPTH(cv))
334 {
335 /* this tells the restore code to increment CvDEPTH */
336 PUSHs (Nullsv);
337 PUSHs ((SV *)cv);
338 }
339
340 PUSHs ((SV *)CvPADLIST(cv));
341 PUSHs ((SV *)cv);
342
343 get_padlist (cv); /* this is a monster */
344 }
345 }
346 else if (CxTYPE(cx) == CXt_FORMAT)
347 {
348 /* I never used formats, so how should I know how these are implemented? */
349 /* my bold guess is as a simple, plain sub... */
350 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
351 }
352 }
353 while (cxix >= 0);
354
355 if (top_si->si_type == PERLSI_MAIN)
356 break;
357
358 top_si = top_si->si_prev;
359 ccstk = top_si->si_cxstack;
360 cxix = top_si->si_cxix;
361 }
362
363 PUTBACK;
364 }
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
370 c->dowarn = PL_dowarn;
371
372 c->curstackinfo = PL_curstackinfo;
373 c->curstack = PL_curstack;
374 c->mainstack = PL_mainstack;
375 c->stack_sp = PL_stack_sp;
376 c->op = PL_op;
377 c->curpad = PL_curpad;
378 c->stack_base = PL_stack_base;
379 c->stack_max = PL_stack_max;
380 c->tmps_stack = PL_tmps_stack;
381 c->tmps_floor = PL_tmps_floor;
382 c->tmps_ix = PL_tmps_ix;
383 c->tmps_max = PL_tmps_max;
384 c->markstack = PL_markstack;
385 c->markstack_ptr = PL_markstack_ptr;
386 c->markstack_max = PL_markstack_max;
387 c->scopestack = PL_scopestack;
388 c->scopestack_ix = PL_scopestack_ix;
389 c->scopestack_max = PL_scopestack_max;
390 c->savestack = PL_savestack;
391 c->savestack_ix = PL_savestack_ix;
392 c->savestack_max = PL_savestack_max;
393 c->retstack = PL_retstack;
394 c->retstack_ix = PL_retstack_ix;
395 c->retstack_max = PL_retstack_max;
396 c->curcop = PL_curcop;
397 }
398
399 /*
400 * destroy the stacks, the callchain etc...
401 * still there is a memleak of 128 bytes...
402 */
403 STATIC void
404 destroy_stacks(pTHX)
405 {
406 /* is this ugly, I ask? */
407 while (PL_scopestack_ix)
408 LEAVE;
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
414 while (PL_curstackinfo->si_next)
415 PL_curstackinfo = PL_curstackinfo->si_next;
416
417 while (PL_curstackinfo)
418 {
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);
428
429 SvREFCNT_dec(PL_curstackinfo->si_stack);
430 Safefree(PL_curstackinfo->si_cxstack);
431 Safefree(PL_curstackinfo);
432 PL_curstackinfo = p;
433 }
434
435 Safefree(PL_tmps_stack);
436 Safefree(PL_markstack);
437 Safefree(PL_scopestack);
438 Safefree(PL_savestack);
439 Safefree(PL_retstack);
440 }
441
442 #define SUB_INIT "Coro::State::_newcoro"
443
444 MODULE = Coro::State PACKAGE = Coro::State
445
446 PROTOTYPES: ENABLE
447
448 BOOT:
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
455 if (!padlist_cache)
456 padlist_cache = newHV ();
457
458 Coro::State
459 _newprocess(args)
460 SV * args
461 PROTOTYPE: $
462 CODE:
463 Coro__State coro;
464
465 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
466 croak ("Coro::State::_newprocess expects an arrayref");
467
468 New (0, coro, 1, struct coro);
469
470 coro->mainstack = 0; /* actual work is done inside transfer */
471 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
472
473 RETVAL = coro;
474 OUTPUT:
475 RETVAL
476
477 void
478 transfer(prev, next, flags = SAVE_DEFAV)
479 Coro::State_or_hashref prev
480 Coro::State_or_hashref next
481 int flags
482 CODE:
483
484 if (prev != next)
485 {
486 /*
487 * this could be done in newprocess which would lead to
488 * extremely elegant and fast (just SAVE/LOAD)
489 * code here, but lazy allocation of stacks has also
490 * some virtues and the overhead of the if() is nil.
491 */
492 if (next->mainstack)
493 {
494 SAVE (prev, flags);
495 LOAD (next);
496 /* mark this state as in-use */
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");
503 }
504 else
505 {
506 /*
507 * emulate part of the perl startup here.
508 */
509 UNOP myop;
510
511 SAVE (prev, -1); /* first get rid of the old state */
512
513 init_stacks (); /* from perl.c */
514 SPAGAIN;
515
516 PL_op = (OP *)&myop;
517 /*PL_curcop = 0;*/
518 SvREFCNT_dec (GvAV (PL_defgv));
519 GvAV (PL_defgv) = next->args;
520
521 Zero(&myop, 1, UNOP);
522 myop.op_next = Nullop;
523 myop.op_flags = OPf_WANT_VOID;
524
525 PUSHMARK(SP);
526 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
527 /*
528 * the next line is slightly wrong, as PL_op->op_next
529 * is actually being executed so we skip the first op.
530 * that doesn't matter, though, since it is only
531 * pp_nextstate and we never return...
532 * ah yes, and I don't care anyways ;)
533 */
534 PUTBACK;
535 PL_op = pp_entersub(aTHX);
536 SPAGAIN;
537
538 ENTER; /* necessary e.g. for dounwind */
539 }
540 }
541
542 void
543 DESTROY(coro)
544 Coro::State coro
545 CODE:
546
547 if (coro->mainstack)
548 {
549 struct coro temp;
550
551 SAVE(aTHX_ (&temp), SAVE_ALL);
552 LOAD(aTHX_ coro);
553
554 destroy_stacks ();
555
556 LOAD((&temp)); /* this will get rid of defsv etc.. */
557 }
558
559 Safefree (coro);
560
561 void
562 flush()
563 CODE:
564 #ifdef MAY_FLUSH
565 flush_padlist_cache ();
566 #endif
567
568