1 |
/* clone implementation, big, slow, useless, but not pointless */ |
2 |
|
3 |
static AV * |
4 |
clone_av (AV *av) |
5 |
{ |
6 |
int i; |
7 |
AV *nav = newAV (); |
8 |
|
9 |
av_fill (nav, AvFILLp (av)); |
10 |
|
11 |
for (i = 0; i <= AvFILLp (av); ++i) |
12 |
AvARRAY (nav)[i] = SvREFCNT_inc (AvARRAY (av)[i]); |
13 |
|
14 |
return nav; |
15 |
} |
16 |
|
17 |
static struct coro * |
18 |
coro_clone (struct coro *coro) |
19 |
{ |
20 |
perl_slots *slot, *nslot; |
21 |
struct coro *ncoro; |
22 |
|
23 |
if (coro->flags & (CF_RUNNING | CF_NEW)) |
24 |
croak ("Coro::State::clone cannot clone new or running states, caught"); |
25 |
|
26 |
if (coro->cctx) |
27 |
croak ("Coro::State::clone cannot clone a state running on a custom C context, caught"); |
28 |
|
29 |
slot = coro->slot; |
30 |
|
31 |
if (slot->curstackinfo->si_type != PERLSI_MAIN) |
32 |
croak ("Coro::State::clone cannot clone a state running on a non-main stack, caught"); |
33 |
|
34 |
Newz (0, ncoro, 1, struct coro); |
35 |
Newz (0, nslot, 1, perl_slots); |
36 |
|
37 |
/* copy first, then fixup */ |
38 |
*ncoro = *coro; |
39 |
*nslot = *slot; |
40 |
ncoro->slot = nslot; |
41 |
|
42 |
nslot->curstackinfo = new_stackinfo (slot->stack_max - slot->stack_sp + 1, slot->curstackinfo->si_cxmax); |
43 |
nslot->curstackinfo->si_type = PERLSI_MAIN; |
44 |
nslot->curstackinfo->si_cxix = slot->curstackinfo->si_cxix; |
45 |
nslot->curstack = nslot->curstackinfo->si_stack; |
46 |
ncoro->mainstack = nslot->curstack; |
47 |
|
48 |
nslot->stack_base = AvARRAY (nslot->curstack); |
49 |
nslot->stack_sp = nslot->stack_base + (slot->stack_sp - slot->stack_base); |
50 |
nslot->stack_max = nslot->stack_base + AvMAX (nslot->curstack); |
51 |
|
52 |
Copy (slot->stack_base, nslot->stack_base, slot->stack_sp - slot->stack_base + 1, SV *); |
53 |
Copy (slot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxix + 1, PERL_CONTEXT); |
54 |
|
55 |
New (50, nslot->tmps_stack, nslot->tmps_max, SV *); |
56 |
Copy (slot->tmps_stack, nslot->tmps_stack, slot->tmps_ix + 1, SV *); |
57 |
|
58 |
New (54, nslot->markstack, slot->markstack_max - slot->markstack + 1, I32); |
59 |
nslot->markstack_ptr = nslot->markstack + (slot->markstack_ptr - slot->markstack); |
60 |
nslot->markstack_max = nslot->markstack + (slot->markstack_max - slot->markstack); |
61 |
Copy (slot->markstack, nslot->markstack, slot->markstack_ptr - slot->markstack + 1, I32); |
62 |
|
63 |
#ifdef SET_MARK_OFFSET |
64 |
//SET_MARK_OFFSET; /*TODO*/ |
65 |
#endif |
66 |
|
67 |
New (54, nslot->scopestack, slot->scopestack_max, I32); |
68 |
Copy (slot->scopestack, nslot->scopestack, slot->scopestack_ix + 1, I32); |
69 |
|
70 |
New (54, nslot->savestack, nslot->savestack_max, ANY); |
71 |
Copy (slot->savestack, nslot->savestack, slot->savestack_ix + 1, ANY); |
72 |
|
73 |
#if !PERL_VERSION_ATLEAST (5,10,0) |
74 |
New (54, nslot->retstack, nslot->retstack_mac, OP *); |
75 |
Copy (slot->retstack, nslot->retstack, slot->retstack_max, OP *); |
76 |
#endif |
77 |
|
78 |
/* first fix up the padlists, by walking up our own saved state */ |
79 |
{ |
80 |
SV **sp = nslot->stack_sp; |
81 |
AV *av; |
82 |
CV *cv; |
83 |
int i; |
84 |
|
85 |
/* now do the ugly restore mess */ |
86 |
while (expect_true (cv = (CV *)POPs)) |
87 |
{ |
88 |
POPs; |
89 |
|
90 |
av = clone_av ((AV *)TOPs); |
91 |
AvREAL_off (av); |
92 |
|
93 |
for (i = 1; i <= AvFILLp (av); ++i) |
94 |
{ |
95 |
SvREFCNT_dec (AvARRAY (av)[i]); |
96 |
AvARRAY (av)[i] = (SV *)clone_av ((AV *)AvARRAY (av)[i]); |
97 |
AvREIFY_on (AvARRAY (av)[i]); |
98 |
} |
99 |
|
100 |
TOPs = (SV *)av; |
101 |
|
102 |
POPs; |
103 |
} |
104 |
} |
105 |
|
106 |
/* easy things first, mortals */ |
107 |
{ |
108 |
int i; |
109 |
|
110 |
for (i = 0; i <= nslot->tmps_ix; ++i) |
111 |
SvREFCNT_inc (nslot->tmps_stack [i]); |
112 |
} |
113 |
|
114 |
/* now fix up the context stack, modelled after cx_dup */ |
115 |
{ |
116 |
I32 cxix = nslot->curstackinfo->si_cxix; |
117 |
PERL_CONTEXT *ccstk = nslot->curstackinfo->si_cxstack; |
118 |
|
119 |
while (expect_true (cxix >= 0)) |
120 |
{ |
121 |
PERL_CONTEXT *cx = &ccstk[cxix--]; |
122 |
|
123 |
switch (CxTYPE (cx)) |
124 |
{ |
125 |
case CXt_SUBST: |
126 |
croak ("Coro::State::clone cannot clone a state inside a substitution context, caught"); |
127 |
|
128 |
case CXt_SUB: |
129 |
if (cx->blk_sub.olddepth == 0) |
130 |
SvREFCNT_inc ((SV *)cx->blk_sub.cv); |
131 |
|
132 |
if (cx->blk_sub.hasargs) |
133 |
{ |
134 |
SvREFCNT_inc ((SV *)cx->blk_sub.argarray); |
135 |
SvREFCNT_inc ((SV *)cx->blk_sub.savearray); |
136 |
} |
137 |
break; |
138 |
|
139 |
case CXt_EVAL: |
140 |
SvREFCNT_inc ((SV *)cx->blk_eval.old_namesv); |
141 |
SvREFCNT_inc ((SV *)cx->blk_eval.cur_text); |
142 |
break; |
143 |
|
144 |
case CXt_LOOP: |
145 |
/*TODO: cx->blk_loop.iterdata*/ |
146 |
SvREFCNT_inc ((SV *)cx->blk_loop.itersave); |
147 |
SvREFCNT_inc ((SV *)cx->blk_loop.iterlval); |
148 |
SvREFCNT_inc ((SV *)cx->blk_loop.iterary); |
149 |
break; |
150 |
|
151 |
case CXt_FORMAT: |
152 |
croak ("Coro::State::clone cannot clone a state inside a format, caught"); |
153 |
break; |
154 |
|
155 |
/* BLOCK, NULL etc. */ |
156 |
} |
157 |
} |
158 |
} |
159 |
|
160 |
/* now fix up the save stack */ |
161 |
/* modelled after ss_dup */ |
162 |
|
163 |
#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) |
164 |
#define TOPINT(ss,ix) ((ss)[ix].any_i32) |
165 |
#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) |
166 |
#define TOPLONG(ss,ix) ((ss)[ix].any_long) |
167 |
#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) |
168 |
#define TOPIV(ss,ix) ((ss)[ix].any_iv) |
169 |
#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) |
170 |
#define TOPBOOL(ss,ix) ((ss)[ix].any_bool) |
171 |
#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) |
172 |
#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) |
173 |
#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) |
174 |
#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) |
175 |
#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) |
176 |
#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) |
177 |
|
178 |
{ |
179 |
ANY * const ss = nslot->savestack; |
180 |
const I32 max = nslot->savestack_max; |
181 |
I32 ix = nslot->savestack_ix; |
182 |
|
183 |
while (ix > 0) |
184 |
{ |
185 |
const I32 type = POPINT (ss, ix); |
186 |
|
187 |
switch (type) |
188 |
{ |
189 |
case SAVEt_HELEM: /* hash element */ |
190 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
191 |
/* fall through */ |
192 |
case SAVEt_ITEM: /* normal string */ |
193 |
case SAVEt_SV: /* scalar reference */ |
194 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
195 |
/* fall through */ |
196 |
case SAVEt_FREESV: |
197 |
case SAVEt_MORTALIZESV: |
198 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
199 |
break; |
200 |
|
201 |
case SAVEt_SHARED_PVREF: /* char* in shared space */ |
202 |
abort (); |
203 |
#if 0 |
204 |
c = (char *) POPPTR (ss, ix); |
205 |
TOPPTR (ss, ix) = savesharedpv (c); |
206 |
ptr = POPPTR (ss, ix); |
207 |
TOPPTR (ss, ix) = any_dup (ptr, proto_perl); |
208 |
#endif |
209 |
break; |
210 |
case SAVEt_GENERIC_SVREF: /* generic sv */ |
211 |
case SAVEt_SVREF: /* scalar reference */ |
212 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
213 |
POPPTR (ss, ix); |
214 |
break; |
215 |
|
216 |
case SAVEt_HV: /* hash reference */ |
217 |
case SAVEt_AV: /* array reference */ |
218 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
219 |
/* fall through */ |
220 |
case SAVEt_COMPPAD: |
221 |
case SAVEt_NSTAB: |
222 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
223 |
break; |
224 |
|
225 |
case SAVEt_INT: /* int reference */ |
226 |
POPPTR (ss, ix); |
227 |
POPINT (ss, ix); |
228 |
break; |
229 |
|
230 |
case SAVEt_LONG: /* long reference */ |
231 |
POPPTR (ss, ix); |
232 |
/* fall through */ |
233 |
case SAVEt_CLEARSV: |
234 |
POPLONG (ss, ix); |
235 |
break; |
236 |
|
237 |
case SAVEt_I32: /* I32 reference */ |
238 |
case SAVEt_I16: /* I16 reference */ |
239 |
case SAVEt_I8: /* I8 reference */ |
240 |
case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ |
241 |
POPPTR (ss, ix); |
242 |
POPINT (ss, ix); |
243 |
break; |
244 |
|
245 |
case SAVEt_IV: /* IV reference */ |
246 |
POPPTR (ss, ix); |
247 |
POPIV (ss, ix); |
248 |
break; |
249 |
|
250 |
case SAVEt_HPTR: /* HV* reference */ |
251 |
case SAVEt_APTR: /* AV* reference */ |
252 |
case SAVEt_SPTR: /* SV* reference */ |
253 |
POPPTR (ss, ix); |
254 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
255 |
break; |
256 |
|
257 |
case SAVEt_VPTR: /* random* reference */ |
258 |
POPPTR (ss, ix); |
259 |
POPPTR (ss, ix); |
260 |
break; |
261 |
case SAVEt_GENERIC_PVREF: /* generic char* */ |
262 |
case SAVEt_PPTR: /* char* reference */ |
263 |
POPPTR (ss, ix); |
264 |
TOPPTR (ss, ix) = savepv ((char *) POPPTR (ss, ix)); |
265 |
break; |
266 |
|
267 |
case SAVEt_GP: /* scalar reference */ |
268 |
((GP *) POPPTR (ss, ix))->gp_refcnt++; |
269 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
270 |
break; |
271 |
|
272 |
case SAVEt_FREEOP: |
273 |
abort (); |
274 |
#if 0 |
275 |
ptr = POPPTR (ss, ix); |
276 |
if (ptr && (((OP *) ptr)->op_private & OPpREFCOUNTED)) |
277 |
{ |
278 |
/* these are assumed to be refcounted properly */ |
279 |
OP *o; |
280 |
|
281 |
switch (((OP *) ptr)->op_type) |
282 |
{ |
283 |
case OP_LEAVESUB: |
284 |
case OP_LEAVESUBLV: |
285 |
case OP_LEAVEEVAL: |
286 |
case OP_LEAVE: |
287 |
case OP_SCOPE: |
288 |
case OP_LEAVEWRITE: |
289 |
TOPPTR (ss, ix) = ptr; |
290 |
o = (OP *) ptr; |
291 |
OP_REFCNT_LOCK; |
292 |
(void) OpREFCNT_inc (o); |
293 |
OP_REFCNT_UNLOCK; |
294 |
break; |
295 |
default: |
296 |
TOPPTR (ss, ix) = NULL; |
297 |
break; |
298 |
} |
299 |
} |
300 |
else |
301 |
TOPPTR (ss, ix) = NULL; |
302 |
#endif |
303 |
break; |
304 |
|
305 |
case SAVEt_FREEPV: |
306 |
TOPPTR (ss, ix) = savepv ((char *) POPPTR (ss, ix)); |
307 |
break; |
308 |
|
309 |
case SAVEt_DELETE: |
310 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
311 |
TOPPTR (ss, ix) = savepv ((char *) POPPTR (ss, ix)); |
312 |
/* fall through */ |
313 |
case SAVEt_STACK_POS: /* Position on Perl stack */ |
314 |
POPINT (ss, ix); |
315 |
break; |
316 |
|
317 |
case SAVEt_DESTRUCTOR: |
318 |
POPPTR (ss, ix); |
319 |
POPDPTR (ss, ix); |
320 |
break; |
321 |
|
322 |
case SAVEt_DESTRUCTOR_X: |
323 |
POPPTR (ss, ix); |
324 |
POPDXPTR (ss, ix); |
325 |
break; |
326 |
|
327 |
case SAVEt_REGCONTEXT: |
328 |
case SAVEt_ALLOC: |
329 |
ix = POPINT (ss, ix); |
330 |
break; |
331 |
|
332 |
case SAVEt_AELEM: /* array element */ |
333 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
334 |
POPINT (ss, ix); |
335 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
336 |
break; |
337 |
case SAVEt_OP: |
338 |
POPPTR (ss, ix); |
339 |
break; |
340 |
case SAVEt_HINTS: |
341 |
abort (); |
342 |
#if 0 |
343 |
{ |
344 |
int i = POPINT (ss, ix); |
345 |
void *ptr = POPPTR (ss, ix); |
346 |
if (ptr) |
347 |
((struct refcounted_he *)ptr)->refcounted_he_refcnt++; |
348 |
|
349 |
if (i & HINT_LOCALIZE_HH) |
350 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
351 |
} |
352 |
#endif |
353 |
break; |
354 |
|
355 |
case SAVEt_PADSV: |
356 |
POPLONG (ss, ix); |
357 |
POPPTR (ss, ix); |
358 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
359 |
break; |
360 |
|
361 |
case SAVEt_BOOL: |
362 |
POPPTR (ss, ix); |
363 |
POPBOOL (ss, ix); |
364 |
break; |
365 |
|
366 |
case SAVEt_SET_SVFLAGS: |
367 |
POPINT (ss, ix); |
368 |
POPINT (ss, ix); |
369 |
SvREFCNT_inc ((SV *) POPPTR (ss, ix)); |
370 |
break; |
371 |
|
372 |
case SAVEt_RE_STATE: |
373 |
abort (); |
374 |
#if 0 |
375 |
{ |
376 |
const struct re_save_state *const old_state = (struct re_save_state *) (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); |
377 |
struct re_save_state *const new_state = (struct re_save_state *) (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); |
378 |
|
379 |
Copy (old_state, new_state, 1, struct re_save_state); |
380 |
|
381 |
ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; |
382 |
|
383 |
new_state->re_state_bostr = pv_dup (old_state->re_state_bostr); |
384 |
new_state->re_state_reginput = pv_dup (old_state->re_state_reginput); |
385 |
new_state->re_state_regeol = pv_dup (old_state->re_state_regeol); |
386 |
new_state->re_state_regoffs = (regexp_paren_pair *) any_dup (old_state->re_state_regoffs, proto_perl); |
387 |
new_state->re_state_reglastparen = (U32 *) any_dup (old_state->re_state_reglastparen, proto_perl); |
388 |
new_state->re_state_reglastcloseparen = (U32 *) any_dup (old_state->re_state_reglastcloseparen, proto_perl); |
389 |
/* XXX This just has to be broken. The old save_re_context |
390 |
code did SAVEGENERICPV(PL_reg_start_tmp); |
391 |
PL_reg_start_tmp is char **. |
392 |
Look above to what the dup code does for |
393 |
SAVEt_GENERIC_PVREF |
394 |
It can never have worked. |
395 |
So this is merely a faithful copy of the exiting bug: */ |
396 |
new_state->re_state_reg_start_tmp = (char **) pv_dup ((char *) old_state->re_state_reg_start_tmp); |
397 |
/* I assume that it only ever "worked" because no-one called |
398 |
(pseudo)fork while the regexp engine had re-entered itself. |
399 |
*/ |
400 |
#ifdef PERL_OLD_COPY_ON_WRITE |
401 |
new_state->re_state_nrs = sv_dup (old_state->re_state_nrs, param); |
402 |
#endif |
403 |
new_state->re_state_reg_magic = (MAGIC *) any_dup (old_state->re_state_reg_magic, proto_perl); |
404 |
new_state->re_state_reg_oldcurpm = (PMOP *) any_dup (old_state->re_state_reg_oldcurpm, proto_perl); |
405 |
new_state->re_state_reg_curpm = (PMOP *) any_dup (old_state->re_state_reg_curpm, proto_perl); |
406 |
new_state->re_state_reg_oldsaved = pv_dup (old_state->re_state_reg_oldsaved); |
407 |
new_state->re_state_reg_poscache = pv_dup (old_state->re_state_reg_poscache); |
408 |
new_state->re_state_reg_starttry = pv_dup (old_state->re_state_reg_starttry); |
409 |
break; |
410 |
} |
411 |
#endif |
412 |
|
413 |
case SAVEt_COMPILE_WARNINGS: |
414 |
abort (); |
415 |
#if 0 |
416 |
ptr = POPPTR (ss, ix); |
417 |
TOPPTR (ss, ix) = DUP_WARNINGS ((STRLEN *) ptr); |
418 |
break; |
419 |
#endif |
420 |
|
421 |
case SAVEt_PARSER: |
422 |
abort (); |
423 |
#if 0 |
424 |
ptr = POPPTR (ss, ix); |
425 |
TOPPTR (ss, ix) = parser_dup ((const yy_parser *) ptr, param); |
426 |
break; |
427 |
#endif |
428 |
default: |
429 |
croak ("panic: ss_dup inconsistency (%" IVdf ")", (IV) type); |
430 |
} |
431 |
} |
432 |
} |
433 |
|
434 |
SvREFCNT_inc (nslot->defsv); |
435 |
SvREFCNT_inc (nslot->defav); |
436 |
SvREFCNT_inc (nslot->errsv); |
437 |
SvREFCNT_inc (nslot->irsgv); |
438 |
|
439 |
SvREFCNT_inc (nslot->defoutgv); |
440 |
SvREFCNT_inc (nslot->rs); |
441 |
SvREFCNT_inc (nslot->compcv); |
442 |
SvREFCNT_inc (nslot->diehook); |
443 |
SvREFCNT_inc (nslot->warnhook); |
444 |
|
445 |
SvREFCNT_inc (ncoro->startcv); |
446 |
SvREFCNT_inc (ncoro->args); |
447 |
SvREFCNT_inc (ncoro->except); |
448 |
|
449 |
return ncoro; |
450 |
} |