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.5 by root, Tue Jul 17 02:55:29 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
6# define CHK(x) (void *)0
7#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9#endif
10
5struct coro { 11struct coro {
6 U8 dowarn; 12 U8 dowarn;
13 AV *defav;
7 14
8 PERL_SI *curstackinfo; 15 PERL_SI *curstackinfo;
9 AV *curstack; 16 AV *curstack;
10 AV *mainstack; 17 AV *mainstack;
11 SV **stack_sp; 18 SV **stack_sp;
… …
29 OP **retstack; 36 OP **retstack;
30 I32 retstack_ix; 37 I32 retstack_ix;
31 I32 retstack_max; 38 I32 retstack_max;
32 COP *curcop; 39 COP *curcop;
33 40
34 AV *defav; 41 AV *args;
35
36 SV *proc;
37}; 42};
38 43
39typedef struct coro *Coro__State; 44typedef struct coro *Coro__State;
40typedef struct coro *Coro__State_or_hashref; 45typedef struct coro *Coro__State_or_hashref;
41 46
42#define SAVE(c) \ 47static HV *padlist_cache;
48
49/* mostly copied from op.c:cv_clone2 */
50STATIC AV *
51clone_padlist (AV *protopadlist)
52{
53 AV *av;
54 I32 ix;
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
57 SV **pname = AvARRAY (protopad_name);
58 SV **ppad = AvARRAY (protopad);
59 I32 fname = AvFILLp (protopad_name);
60 I32 fpad = AvFILLp (protopad);
61 AV *newpadlist, *newpad_name, *newpad;
62 SV **npad;
63
64 newpad_name = newAV ();
65 for (ix = fname; ix >= 0; ix--)
66 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67
68 newpad = newAV ();
69 av_fill (newpad, AvFILLp (protopad));
70 npad = AvARRAY (newpad);
71
72 newpadlist = newAV ();
73 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name);
75 av_store (newpadlist, 1, (SV *) newpad);
76
77 av = newAV (); /* will be @_ */
78 av_extend (av, 0);
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81
82 for (ix = fpad; ix > 0; ix--)
83 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
85 if (namesv && namesv != &PL_sv_undef)
86 {
87 char *name = SvPVX (namesv); /* XXX */
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 }
92 else
93 { /* our own lexical */
94 SV *sv;
95 if (*name == '&')
96 sv = SvREFCNT_inc (ppad[ix]);
97 else if (*name == '@')
98 sv = (SV *) newAV ();
99 else if (*name == '%')
100 sv = (SV *) newHV ();
101 else
102 sv = NEWSV (0, 0);
103 if (!SvPADBUSY (sv))
104 SvPADMY_on (sv);
105 npad[ix] = sv;
106 }
107 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
109 {
110 npad[ix] = SvREFCNT_inc (ppad[ix]);
111 }
112 else
113 {
114 SV *sv = NEWSV (0, 0);
115 SvPADTMP_on (sv);
116 npad[ix] = sv;
117 }
118 }
119
120#if 0 /* NONOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */
122
123 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv
126 && namesv != &PL_sv_undef
127 && !(SvFLAGS(namesv) & SVf_FAKE)
128 && *SvPVX(namesv) == '&'
129 && CvCLONE(ppad[ix]))
130 {
131 CV *kid = cv_clone((CV*)ppad[ix]);
132 SvREFCNT_dec(ppad[ix]);
133 CvCLONE_on(kid);
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 }
137 }
138#endif
139
140 return newpadlist;
141}
142
143STATIC AV *
144free_padlist (AV *padlist)
145{
146 /* may be during global destruction */
147 if (SvREFCNT(padlist))
148 {
149 I32 i = AvFILLp(padlist);
150 while (i >= 0)
151 {
152 SV **svp = av_fetch(padlist, i--, FALSE);
153 SV *sv = svp ? *svp : Nullsv;
154 if (sv)
155 SvREFCNT_dec(sv);
156 }
157
158 SvREFCNT_dec((SV*)padlist);
159 }
160}
161
162/* the next tow functions merely cache the padlists */
163STATIC void
164get_padlist (CV *cv)
165{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167
168 if (he && AvFILLp ((AV *)*he) >= 0)
169 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
170 else
171 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172}
173
174STATIC void
175put_padlist (CV *cv)
176{
177 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
178
179 if (SvTYPE (*he) != SVt_PVAV)
180 {
181 SvREFCNT_dec (*he);
182 *he = (SV *)newAV ();
183 }
184
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186}
187
188static void
189SAVE(pTHX_ Coro__State c)
190{
191 {
192 dSP;
193 I32 cxix = cxstack_ix;
194 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196
197 /*
198 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :(
200 */
201
202 PUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */
204 for (;;)
205 {
206 while (cxix >= 0)
207 {
208 PERL_CONTEXT *cx = &ccstk[cxix--];
209
210 if (CxTYPE(cx) == CXt_SUB)
211 {
212 CV *cv = cx->blk_sub.cv;
213 if (CvDEPTH(cv))
214 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv));
221 PUSHs ((SV *)cv);
222
223 get_padlist (cv);
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 }
233 }
234 else if (CxTYPE(cx) == CXt_FORMAT)
235 {
236 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 }
240 }
241
242 if (top_si->si_type == PERLSI_MAIN)
243 break;
244
245 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix;
248 }
249
250 PUTBACK;
251 }
252
43 c->dowarn = PL_dowarn; \ 253 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); 254 c->defav = GvAV (PL_defgv);
255 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp;
259 c->op = PL_op;
260 c->curpad = PL_curpad;
261 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max;
263 c->tmps_stack = PL_tmps_stack;
264 c->tmps_floor = PL_tmps_floor;
265 c->tmps_ix = PL_tmps_ix;
266 c->tmps_max = PL_tmps_max;
267 c->markstack = PL_markstack;
268 c->markstack_ptr = PL_markstack_ptr;
269 c->markstack_max = PL_markstack_max;
270 c->scopestack = PL_scopestack;
271 c->scopestack_ix = PL_scopestack_ix;
272 c->scopestack_max = PL_scopestack_max;
273 c->savestack = PL_savestack;
274 c->savestack_ix = PL_savestack_ix;
275 c->savestack_max = PL_savestack_max;
276 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop;
280}
70 281
71#define LOAD(c) \ 282static void
283LOAD(pTHX_ Coro__State c)
284{
72 PL_dowarn = c->dowarn; \ 285 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; 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}
99 335
100/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
101STATIC void 337STATIC void
102S_nuke_stacks(pTHX) 338destroy_stacks(pTHX)
103{ 339{
340 /* die does this while calling POPSTACK, but I just don't see why. */
341 dounwind(-1);
342
343 /* is this ugly, I ask? */
344 while (PL_scopestack_ix)
345 LEAVE;
346
104 while (PL_curstackinfo->si_next) 347 while (PL_curstackinfo->si_next)
105 PL_curstackinfo = PL_curstackinfo->si_next; 348 PL_curstackinfo = PL_curstackinfo->si_next;
349
106 while (PL_curstackinfo) { 350 while (PL_curstackinfo)
351 {
107 PERL_SI *p = PL_curstackinfo->si_prev; 352 PERL_SI *p = PL_curstackinfo->si_prev;
108 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 353
354 SvREFCNT_dec(PL_curstackinfo->si_stack);
109 Safefree(PL_curstackinfo->si_cxstack); 355 Safefree(PL_curstackinfo->si_cxstack);
110 Safefree(PL_curstackinfo); 356 Safefree(PL_curstackinfo);
111 PL_curstackinfo = p; 357 PL_curstackinfo = p;
112 } 358 }
359
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 */
113 Safefree(PL_tmps_stack); 373 Safefree(PL_tmps_stack);
114 Safefree(PL_markstack); 374 Safefree(PL_markstack);
115 Safefree(PL_scopestack); 375 Safefree(PL_scopestack);
116 Safefree(PL_savestack); 376 Safefree(PL_savestack);
117 Safefree(PL_retstack); 377 Safefree(PL_retstack);
118} 378}
119 379
380#define SUB_INIT "Coro::State::_newcoro"
381
120MODULE = Coro::State PACKAGE = Coro::State 382MODULE = Coro::State PACKAGE = Coro::State
121 383
122PROTOTYPES: ENABLE 384PROTOTYPES: ENABLE
123 385
386BOOT:
387 if (!padlist_cache)
388 padlist_cache = newHV ();
389
124Coro::State 390Coro::State
125newprocess(proc) 391_newprocess(args)
126 SV * proc 392 SV * args
127 PROTOTYPE: & 393 PROTOTYPE: $
128 CODE: 394 CODE:
129 Coro__State coro; 395 Coro__State coro;
396
397 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398 croak ("Coro::State::newprocess expects an arrayref");
130 399
131 New (0, coro, 1, struct coro); 400 New (0, coro, 1, struct coro);
132 401
133 coro->mainstack = 0; /* actual work is done inside transfer */ 402 coro->mainstack = 0; /* actual work is done inside transfer */
134 coro->proc = SvREFCNT_inc (proc); 403 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
135 404
136 RETVAL = coro; 405 RETVAL = coro;
137 OUTPUT: 406 OUTPUT:
138 RETVAL 407 RETVAL
139 408
140void 409void
141transfer(prev,next) 410transfer(prev,next)
142 Coro::State_or_hashref prev 411 Coro::State_or_hashref prev
143 Coro::State_or_hashref next 412 Coro::State_or_hashref next
144 CODE: 413 CODE:
145 414
146 if (prev != next) 415 if (prev != next)
147 { 416 {
148 PUTBACK; 417 PUTBACK;
149 SAVE (prev); 418 SAVE (aTHX_ prev);
150 419
151 /* 420 /*
152 * this could be done in newprocess which would to 421 * this could be done in newprocess which would lead to
153 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 422 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
154 * code here, but lazy allocation of stacks has also 423 * code here, but lazy allocation of stacks has also
155 * some virtues and the overhead of the if() is nil. 424 * some virtues and the overhead of the if() is nil.
156 */ 425 */
157 if (next->mainstack) 426 if (next->mainstack)
158 { 427 {
159 LOAD (next); 428 LOAD (aTHX_ next);
160 next->mainstack = 0; /* unnecessary but much cleaner */ 429 next->mainstack = 0; /* unnecessary but much cleaner */
161 SPAGAIN; 430 SPAGAIN;
162 } 431 }
163 else 432 else
164 { 433 {
165 /* 434 /*
166 * emulate part of the perl startup here. 435 * emulate part of the perl startup here.
167 */ 436 */
168 UNOP myop; 437 UNOP myop;
169 438
170 init_stacks (); 439 init_stacks (); /* from perl.c */
171 PL_op = (OP *)&myop; 440 PL_op = (OP *)&myop;
172 /*PL_curcop = 0;*/ 441 /*PL_curcop = 0;*/
173 GvAV (PL_defgv) = newAV (); 442 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
174 443
175 SPAGAIN; 444 SPAGAIN;
176 Zero(&myop, 1, UNOP); 445 Zero(&myop, 1, UNOP);
177 myop.op_next = Nullop; 446 myop.op_next = Nullop;
178 myop.op_flags = OPf_WANT_VOID; 447 myop.op_flags = OPf_WANT_VOID;
179 448
180 EXTEND (SP,1); 449 PUSHMARK(SP);
181 PUSHs (next->proc); 450 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
182
183 PUTBACK; 451 PUTBACK;
184 /* 452 /*
185 * the next line is slightly wrong, as PL_op->op_next 453 * the next line is slightly wrong, as PL_op->op_next
186 * is actually being executed so we skip the first op 454 * is actually being executed so we skip the first op.
187 * that doens't matter, though, since it is only 455 * that doesn't matter, though, since it is only
188 * pp_nextstate and we never return... 456 * pp_nextstate and we never return...
189 */ 457 */
190 PL_op = Perl_pp_entersub(aTHX); 458 PL_op = Perl_pp_entersub(aTHX);
191 SPAGAIN; 459 SPAGAIN;
192 460
… …
194 } 462 }
195 } 463 }
196 464
197void 465void
198DESTROY(coro) 466DESTROY(coro)
199 Coro::State coro 467 Coro::State coro
200 CODE: 468 CODE:
201 469
202 if (coro->mainstack) 470 if (coro->mainstack)
203 { 471 {
204 struct coro temp; 472 struct coro temp;
205 473
206 PUTBACK; 474 PUTBACK;
207 SAVE((&temp)); 475 SAVE(aTHX_ (&temp));
208 LOAD(coro); 476 LOAD(aTHX_ coro);
209 477
210 S_nuke_stacks (); 478 destroy_stacks ();
211 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
212 480
213 LOAD((&temp)); 481 LOAD((&temp));
214 SPAGAIN; 482 SPAGAIN;
215 } 483 }
216 484
217 SvREFCNT_dec (coro->proc); 485 SvREFCNT_dec (coro->args);
218 Safefree (coro); 486 Safefree (coro);
219 487
220 488

Diff Legend

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