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.1 by root, Sat Jul 14 22:14:21 2001 UTC vs.
Revision 1.4 by root, Tue Jul 17 02:21:56 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 SV *proc; 41 AV *args;
35}; 42};
36 43
37typedef struct coro *Coro__State; 44typedef struct coro *Coro__State;
38typedef struct coro *Coro__State_or_hashref; 45typedef struct coro *Coro__State_or_hashref;
39 46
40#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
41 c->dowarn = PL_dowarn; \ 253 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv);
42 c->curstackinfo = PL_curstackinfo; \ 255 c->curstackinfo = PL_curstackinfo;
43 c->curstack = PL_curstack; \ 256 c->curstack = PL_curstack;
44 c->mainstack = PL_mainstack; \ 257 c->mainstack = PL_mainstack;
45 c->stack_sp = PL_stack_sp; \ 258 c->stack_sp = PL_stack_sp;
46 c->op = PL_op; \ 259 c->op = PL_op;
47 c->curpad = PL_curpad; \ 260 c->curpad = PL_curpad;
48 c->stack_base = PL_stack_base; \ 261 c->stack_base = PL_stack_base;
49 c->stack_max = PL_stack_max; \ 262 c->stack_max = PL_stack_max;
50 c->tmps_stack = PL_tmps_stack; \ 263 c->tmps_stack = PL_tmps_stack;
51 c->tmps_floor = PL_tmps_floor; \ 264 c->tmps_floor = PL_tmps_floor;
52 c->tmps_ix = PL_tmps_ix; \ 265 c->tmps_ix = PL_tmps_ix;
53 c->tmps_max = PL_tmps_max; \ 266 c->tmps_max = PL_tmps_max;
54 c->markstack = PL_markstack; \ 267 c->markstack = PL_markstack;
55 c->markstack_ptr = PL_markstack_ptr; \ 268 c->markstack_ptr = PL_markstack_ptr;
56 c->markstack_max = PL_markstack_max; \ 269 c->markstack_max = PL_markstack_max;
57 c->scopestack = PL_scopestack; \ 270 c->scopestack = PL_scopestack;
58 c->scopestack_ix = PL_scopestack_ix; \ 271 c->scopestack_ix = PL_scopestack_ix;
59 c->scopestack_max = PL_scopestack_max;\ 272 c->scopestack_max = PL_scopestack_max;
60 c->savestack = PL_savestack; \ 273 c->savestack = PL_savestack;
61 c->savestack_ix = PL_savestack_ix; \ 274 c->savestack_ix = PL_savestack_ix;
62 c->savestack_max = PL_savestack_max; \ 275 c->savestack_max = PL_savestack_max;
63 c->retstack = PL_retstack; \ 276 c->retstack = PL_retstack;
64 c->retstack_ix = PL_retstack_ix; \ 277 c->retstack_ix = PL_retstack_ix;
65 c->retstack_max = PL_retstack_max; \ 278 c->retstack_max = PL_retstack_max;
66 c->curcop = PL_curcop; 279 c->curcop = PL_curcop;
280}
67 281
68#define LOAD(c) \ 282static void
283LOAD(pTHX_ Coro__State c)
284{
69 PL_dowarn = c->dowarn; \ 285 PL_dowarn = c->dowarn;
286 GvAV (PL_defgv) = c->defav;
70 PL_curstackinfo = c->curstackinfo; \ 287 PL_curstackinfo = c->curstackinfo;
71 PL_curstack = c->curstack; \ 288 PL_curstack = c->curstack;
72 PL_mainstack = c->mainstack; \ 289 PL_mainstack = c->mainstack;
73 PL_stack_sp = c->stack_sp; \ 290 PL_stack_sp = c->stack_sp;
74 PL_op = c->op; \ 291 PL_op = c->op;
75 PL_curpad = c->curpad; \ 292 PL_curpad = c->curpad;
76 PL_stack_base = c->stack_base; \ 293 PL_stack_base = c->stack_base;
77 PL_stack_max = c->stack_max; \ 294 PL_stack_max = c->stack_max;
78 PL_tmps_stack = c->tmps_stack; \ 295 PL_tmps_stack = c->tmps_stack;
79 PL_tmps_floor = c->tmps_floor; \ 296 PL_tmps_floor = c->tmps_floor;
80 PL_tmps_ix = c->tmps_ix; \ 297 PL_tmps_ix = c->tmps_ix;
81 PL_tmps_max = c->tmps_max; \ 298 PL_tmps_max = c->tmps_max;
82 PL_markstack = c->markstack; \ 299 PL_markstack = c->markstack;
83 PL_markstack_ptr = c->markstack_ptr; \ 300 PL_markstack_ptr = c->markstack_ptr;
84 PL_markstack_max = c->markstack_max; \ 301 PL_markstack_max = c->markstack_max;
85 PL_scopestack = c->scopestack; \ 302 PL_scopestack = c->scopestack;
86 PL_scopestack_ix = c->scopestack_ix; \ 303 PL_scopestack_ix = c->scopestack_ix;
87 PL_scopestack_max = c->scopestack_max;\ 304 PL_scopestack_max = c->scopestack_max;
88 PL_savestack = c->savestack; \ 305 PL_savestack = c->savestack;
89 PL_savestack_ix = c->savestack_ix; \ 306 PL_savestack_ix = c->savestack_ix;
90 PL_savestack_max = c->savestack_max; \ 307 PL_savestack_max = c->savestack_max;
91 PL_retstack = c->retstack; \ 308 PL_retstack = c->retstack;
92 PL_retstack_ix = c->retstack_ix; \ 309 PL_retstack_ix = c->retstack_ix;
93 PL_retstack_max = c->retstack_max; \ 310 PL_retstack_max = c->retstack_max;
94 PL_curcop = c->curcop; 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}
95 335
96/* 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 */
97STATIC void 337STATIC void
98S_nuke_stacks(pTHX) 338destroy_stacks(pTHX)
99{ 339{
340 dSP;
341
342 /* die does this while calling POPSTACK, but I just don't see why. */
343 dounwind(-1);
344
345 /* is this ugly, I ask? */
346 while (PL_scopestack_ix)
347 LEAVE;
348
100 while (PL_curstackinfo->si_next) 349 while (PL_curstackinfo->si_next)
101 PL_curstackinfo = PL_curstackinfo->si_next; 350 PL_curstackinfo = PL_curstackinfo->si_next;
351
102 while (PL_curstackinfo) { 352 while (PL_curstackinfo)
353 {
103 PERL_SI *p = PL_curstackinfo->si_prev; 354 PERL_SI *p = PL_curstackinfo->si_prev;
104 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 355
356 SvREFCNT_dec(PL_curstackinfo->si_stack);
105 Safefree(PL_curstackinfo->si_cxstack); 357 Safefree(PL_curstackinfo->si_cxstack);
106 Safefree(PL_curstackinfo); 358 Safefree(PL_curstackinfo);
107 PL_curstackinfo = p; 359 PL_curstackinfo = p;
108 } 360 }
361
362 if (PL_scopestack_ix != 0)
363 Perl_warner(aTHX_ WARN_INTERNAL,
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365 (long)PL_scopestack_ix);
366 if (PL_savestack_ix != 0)
367 Perl_warner(aTHX_ WARN_INTERNAL,
368 "Unbalanced saves: %ld more saves than restores\n",
369 (long)PL_savestack_ix);
370 if (PL_tmps_floor != -1)
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372 (long)PL_tmps_floor + 1);
373 /*
374 */
109 Safefree(PL_tmps_stack); 375 Safefree(PL_tmps_stack);
110 Safefree(PL_markstack); 376 Safefree(PL_markstack);
111 Safefree(PL_scopestack); 377 Safefree(PL_scopestack);
112 Safefree(PL_savestack); 378 Safefree(PL_savestack);
113 Safefree(PL_retstack); 379 Safefree(PL_retstack);
114} 380}
115 381
382#define SUB_INIT "Coro::State::_newcoro"
383
116MODULE = Coro::State PACKAGE = Coro::State 384MODULE = Coro::State PACKAGE = Coro::State
117 385
118PROTOTYPES: ENABLE 386PROTOTYPES: ENABLE
119 387
388BOOT:
389 if (!padlist_cache)
390 padlist_cache = newHV ();
391
120Coro::State 392Coro::State
121newprocess(proc) 393_newprocess(args)
122 SV * proc 394 SV * args
123 PROTOTYPE: & 395 PROTOTYPE: $
124 CODE: 396 CODE:
125 Coro__State coro; 397 Coro__State coro;
398
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400 croak ("Coro::State::newprocess expects an arrayref");
126 401
127 New (0, coro, 1, struct coro); 402 New (0, coro, 1, struct coro);
128 403
129 coro->mainstack = 0; /* actual work is done inside transfer */ 404 coro->mainstack = 0; /* actual work is done inside transfer */
130 coro->proc = SvREFCNT_inc (proc); 405 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
131 406
132 RETVAL = coro; 407 RETVAL = coro;
133 OUTPUT: 408 OUTPUT:
134 RETVAL 409 RETVAL
135 410
136void 411void
137transfer(prev,next) 412transfer(prev,next)
138 Coro::State_or_hashref prev 413 Coro::State_or_hashref prev
139 Coro::State_or_hashref next 414 Coro::State_or_hashref next
140 CODE: 415 CODE:
141 416
142 PUTBACK; 417 if (prev != next)
143 SAVE (prev);
144
145 /*
146 * this could be done in newprocess which would to
147 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
148 * code here, but lazy allocation of stacks has also
149 * some virtues and the overhead of the if() is nil.
150 */
151 if (next->mainstack)
152 { 418 {
153 LOAD (next);
154 next->mainstack = 0; /* unnecessary but much cleaner */
155 SPAGAIN; 419 PUTBACK;
156 } 420 SAVE (aTHX_ prev);
157 else 421
158 {
159 /* 422 /*
160 * emulate part of the perl startup here. 423 * this could be done in newprocess which would lead to
424 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425 * code here, but lazy allocation of stacks has also
426 * some virtues and the overhead of the if() is nil.
161 */ 427 */
428 if (next->mainstack)
429 {
430 LOAD (aTHX_ next);
431 next->mainstack = 0; /* unnecessary but much cleaner */
432 SPAGAIN;
433 }
434 else
435 {
436 /*
437 * emulate part of the perl startup here.
438 */
162 UNOP myop; 439 UNOP myop;
163 440
164 init_stacks (); 441 init_stacks (); /* from perl.c */
165 PL_op = (OP *)&myop; 442 PL_op = (OP *)&myop;
166 /*PL_curcop = 0;*/ 443 /*PL_curcop = 0;*/
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
167 445
168 SPAGAIN; 446 SPAGAIN;
169 Zero(&myop, 1, UNOP); 447 Zero(&myop, 1, UNOP);
170 myop.op_next = Nullop; 448 myop.op_next = Nullop;
171 myop.op_flags = OPf_WANT_VOID; 449 myop.op_flags = OPf_WANT_VOID;
172 450
173 EXTEND (SP,1); 451 PUSHMARK(SP);
174 PUSHs (next->proc); 452 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
175
176 PUTBACK; 453 PUTBACK;
177 /* 454 /*
178 * the next line is slightly wrong, as PL_op->op_next 455 * the next line is slightly wrong, as PL_op->op_next
179 * is actually being executed so we skip the first op 456 * is actually being executed so we skip the first op.
180 * that doens't matter, though, since it is only 457 * that doesn't matter, though, since it is only
181 * pp_nextstate and we never return... 458 * pp_nextstate and we never return...
182 */ 459 */
183 PL_op = Perl_pp_entersub(aTHX); 460 PL_op = Perl_pp_entersub(aTHX);
184 SPAGAIN; 461 SPAGAIN;
185 462
186 ENTER; 463 ENTER;
464 }
187 } 465 }
188 466
189void 467void
190DESTROY(coro) 468DESTROY(coro)
191 Coro::State coro 469 Coro::State coro
192 CODE: 470 CODE:
193 471
194 if (coro->mainstack) 472 if (coro->mainstack)
195 { 473 {
196 struct coro temp; 474 struct coro temp;
197 475
198 PUTBACK; 476 PUTBACK;
199 SAVE((&temp)); 477 SAVE(aTHX_ (&temp));
200 LOAD(coro); 478 LOAD(aTHX_ coro);
201 479
202 S_nuke_stacks (); 480 destroy_stacks ();
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
203 482
204 LOAD((&temp)); 483 LOAD((&temp));
205 SPAGAIN; 484 SPAGAIN;
206 } 485 }
207 486
208 SvREFCNT_dec (coro->proc); 487 SvREFCNT_dec (coro->args);
209 Safefree (coro); 488 Safefree (coro);
210 489
211 490

Diff Legend

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