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