This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Un-revert "[MERGE] add+use si_cxsubix field"
[perl5.git] / scope.c
1 /*    scope.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * For the fashion of Minas Tirith was such that it was built on seven
13  * levels...
14  *
15  *     [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"]
16  */
17
18 /* This file contains functions to manipulate several of Perl's stacks;
19  * in particular it contains code to push various types of things onto
20  * the savestack, then to pop them off and perform the correct restorative
21  * action for each one. This corresponds to the cleanup Perl does at
22  * each scope exit.
23  */
24
25 #include "EXTERN.h"
26 #define PERL_IN_SCOPE_C
27 #include "perl.h"
28
29 SV**
30 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
31 {
32     SSize_t extra;
33     SSize_t current = (p - PL_stack_base);
34
35     PERL_ARGS_ASSERT_STACK_GROW;
36
37     if (UNLIKELY(n < 0))
38         Perl_croak(aTHX_
39             "panic: stack_grow() negative count (%" IVdf ")", (IV)n);
40
41     PL_stack_sp = sp;
42     extra =
43 #ifdef STRESS_REALLOC
44         1;
45 #else
46         128;
47 #endif
48     /* If the total might wrap, panic instead. This is really testing
49      * that (current + n + extra < SSize_t_MAX), but done in a way that
50      * can't wrap */
51     if (UNLIKELY(   current         > SSize_t_MAX - extra
52                  || current + extra > SSize_t_MAX - n
53     ))
54         /* diag_listed_as: Out of memory during %s extend */
55         Perl_croak(aTHX_ "Out of memory during stack extend");
56
57     av_extend(PL_curstack, current + n + extra);
58 #ifdef DEBUGGING
59         PL_curstackinfo->si_stack_hwm = current + n + extra;
60 #endif
61
62     return PL_stack_sp;
63 }
64
65 #ifndef STRESS_REALLOC
66 #define GROW(old) ((old) * 3 / 2)
67 #else
68 #define GROW(old) ((old) + 1)
69 #endif
70
71 PERL_SI *
72 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
73 {
74     PERL_SI *si;
75     Newx(si, 1, PERL_SI);
76     si->si_stack = newAV();
77     AvREAL_off(si->si_stack);
78     av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
79     AvALLOC(si->si_stack)[0] = &PL_sv_undef;
80     AvFILLp(si->si_stack) = 0;
81     si->si_prev = 0;
82     si->si_next = 0;
83     si->si_cxmax = cxitems - 1;
84     si->si_cxix = -1;
85     si->si_cxsubix = -1;
86     si->si_type = PERLSI_UNDEF;
87     Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
88     /* Without any kind of initialising CX_PUSHSUBST()
89      * in pp_subst() will read uninitialised heap. */
90     PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
91     return si;
92 }
93
94 I32
95 Perl_cxinc(pTHX)
96 {
97     const IV old_max = cxstack_max;
98     const IV new_max = GROW(cxstack_max);
99     Renew(cxstack, new_max + 1, PERL_CONTEXT);
100     cxstack_max = new_max;
101     /* Without any kind of initialising deep enough recursion
102      * will end up reading uninitialised PERL_CONTEXTs. */
103     PoisonNew(cxstack + old_max + 1, new_max - old_max, PERL_CONTEXT);
104     return cxstack_ix + 1;
105 }
106
107 void
108 Perl_push_scope(pTHX)
109 {
110     if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) {
111         const IV new_max = GROW(PL_scopestack_max);
112         Renew(PL_scopestack, new_max, I32);
113 #ifdef DEBUGGING
114         Renew(PL_scopestack_name, new_max, const char*);
115 #endif
116         PL_scopestack_max = new_max;
117     }
118 #ifdef DEBUGGING
119     PL_scopestack_name[PL_scopestack_ix] = "unknown";
120 #endif
121     PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
122
123 }
124
125 void
126 Perl_pop_scope(pTHX)
127 {
128     const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
129     LEAVE_SCOPE(oldsave);
130 }
131
132 I32 *
133 Perl_markstack_grow(pTHX)
134 {
135     const I32 oldmax = PL_markstack_max - PL_markstack;
136     const I32 newmax = GROW(oldmax);
137
138     Renew(PL_markstack, newmax, I32);
139     PL_markstack_max = PL_markstack + newmax;
140     PL_markstack_ptr = PL_markstack + oldmax;
141     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
142             "MARK grow %p %" IVdf " by %" IVdf "\n",
143             PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax)));
144     return PL_markstack_ptr;
145 }
146
147 void
148 Perl_savestack_grow(pTHX)
149 {
150     IV new_max;
151 #ifdef STRESS_REALLOC
152     new_max = PL_savestack_max + SS_MAXPUSH;
153 #else
154     new_max = GROW(PL_savestack_max);
155 #endif
156     /* Note that we allocate SS_MAXPUSH slots higher than ss_max
157      * so that SS_ADD_END(), SSGROW() etc can do a simper check */
158     Renew(PL_savestack, new_max + SS_MAXPUSH, ANY);
159     PL_savestack_max = new_max;
160 }
161
162 void
163 Perl_savestack_grow_cnt(pTHX_ I32 need)
164 {
165     const IV new_max = PL_savestack_ix + need;
166     /* Note that we allocate SS_MAXPUSH slots higher than ss_max
167      * so that SS_ADD_END(), SSGROW() etc can do a simper check */
168     Renew(PL_savestack, new_max + SS_MAXPUSH, ANY);
169     PL_savestack_max = new_max;
170 }
171
172 #undef GROW
173
174 /*  The original function was called Perl_tmps_grow and was removed from public
175     API, Perl_tmps_grow_p is the replacement and it used in public macros but
176     isn't public itself.
177
178     Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by,
179     where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max
180     Upon return, PL_tmps_stack[ix] will be a valid address. For machine code
181     optimization and register usage reasons, the proposed ix passed into
182     tmps_grow is returned to the caller which the caller can then use to write
183     an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in
184     pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of
185     tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller
186     must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is
187     appropriate. The assignment to PL_temps_ix can happen before or after
188     tmps_grow call since tmps_grow doesn't look at PL_tmps_ix.
189  */
190
191 SSize_t
192 Perl_tmps_grow_p(pTHX_ SSize_t ix)
193 {
194     SSize_t extend_to = ix;
195 #ifndef STRESS_REALLOC
196     if (ix - PL_tmps_max < 128)
197         extend_to += (PL_tmps_max < 512) ? 128 : 512;
198 #endif
199     Renew(PL_tmps_stack, extend_to + 1, SV*);
200     PL_tmps_max = extend_to + 1;
201     return ix;
202 }
203
204
205 void
206 Perl_free_tmps(pTHX)
207 {
208     /* XXX should tmps_floor live in cxstack? */
209     const SSize_t myfloor = PL_tmps_floor;
210     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
211         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
212 #ifdef PERL_POISON
213         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
214 #endif
215         if (LIKELY(sv)) {
216             SvTEMP_off(sv);
217             SvREFCNT_dec_NN(sv);                /* note, can modify tmps_ix!!! */
218         }
219     }
220 }
221
222 STATIC SV *
223 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
224 {
225     SV * osv;
226     SV *sv;
227
228     PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
229
230     osv = *sptr;
231     if (flags & SAVEf_KEEPOLDELEM)
232         sv = osv;
233     else {
234         sv  = (*sptr = newSV(0));
235         if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv))
236             mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
237     }
238
239     return sv;
240 }
241
242 void
243 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
244 {
245     dSS_ADD;
246     SS_ADD_PTR(ptr1);
247     SS_ADD_PTR(ptr2);
248     SS_ADD_UV(type);
249     SS_ADD_END(3);
250 }
251
252 SV *
253 Perl_save_scalar(pTHX_ GV *gv)
254 {
255     SV ** const sptr = &GvSVn(gv);
256
257     PERL_ARGS_ASSERT_SAVE_SCALAR;
258
259     if (UNLIKELY(SvGMAGICAL(*sptr))) {
260         PL_localizing = 1;
261         (void)mg_get(*sptr);
262         PL_localizing = 0;
263     }
264     save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
265     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
266 }
267
268 /* Like save_sptr(), but also SvREFCNT_dec()s the new value.  Can be used to
269  * restore a global SV to its prior contents, freeing new value. */
270 void
271 Perl_save_generic_svref(pTHX_ SV **sptr)
272 {
273     PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
274
275     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
276 }
277
278 /* Like save_pptr(), but also Safefree()s the new value if it is different
279  * from the old one.  Can be used to restore a global char* to its prior
280  * contents, freeing new value. */
281 void
282 Perl_save_generic_pvref(pTHX_ char **str)
283 {
284     PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
285
286     save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
287 }
288
289 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
290  * Can be used to restore a shared global char* to its prior
291  * contents, freeing new value. */
292 void
293 Perl_save_shared_pvref(pTHX_ char **str)
294 {
295     PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
296
297     save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
298 }
299
300 /* set the SvFLAGS specified by mask to the values in val */
301
302 void
303 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
304 {
305     dSS_ADD;
306
307     PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
308
309     SS_ADD_PTR(sv);
310     SS_ADD_INT(mask);
311     SS_ADD_INT(val);
312     SS_ADD_UV(SAVEt_SET_SVFLAGS);
313     SS_ADD_END(4);
314 }
315
316 /*
317
318 =head1 GV Functions
319
320 =for apidoc save_gp
321
322 Saves the current GP of gv on the save stack to be restored on scope exit.
323
324 If empty is true, replace the GP with a new GP.
325
326 If empty is false, mark gv with GVf_INTRO so the next reference
327 assigned is localized, which is how C< local *foo = $someref; > works.
328
329 =cut
330 */
331
332 void
333 Perl_save_gp(pTHX_ GV *gv, I32 empty)
334 {
335     PERL_ARGS_ASSERT_SAVE_GP;
336
337     /* XXX For now, we just upgrade any coderef in the stash to a full GV
338            during localisation.  Maybe at some point we could make localis-
339            ation work without needing the upgrade.  (In which case our
340            callers should probably call a different function, not save_gp.)
341      */
342     if (!isGV(gv)) {
343         assert(isGV_or_RVCV(gv));
344         (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */
345         assert(isGV(gv));
346     }
347
348     save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
349
350     if (empty) {
351         GP *gp = Perl_newGP(aTHX_ gv);
352         HV * const stash = GvSTASH(gv);
353         bool isa_changed = 0;
354
355         if (stash && HvENAME(stash)) {
356             if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
357                 isa_changed = TRUE;
358             else if (GvCVu(gv))
359                 /* taking a method out of circulation ("local")*/
360                 mro_method_changed_in(stash);
361         }
362         if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
363             gp->gp_io = newIO();
364             IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
365         }
366         GvGP_set(gv,gp);
367         if (isa_changed) mro_isa_changed_in(stash);
368     }
369     else {
370         gp_ref(GvGP(gv));
371         GvINTRO_on(gv);
372     }
373 }
374
375 AV *
376 Perl_save_ary(pTHX_ GV *gv)
377 {
378     AV * const oav = GvAVn(gv);
379     AV *av;
380
381     PERL_ARGS_ASSERT_SAVE_ARY;
382
383     if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav)))
384         av_reify(oav);
385     save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
386
387     GvAV(gv) = NULL;
388     av = GvAVn(gv);
389     if (UNLIKELY(SvMAGIC(oav)))
390         mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
391     return av;
392 }
393
394 HV *
395 Perl_save_hash(pTHX_ GV *gv)
396 {
397     HV *ohv, *hv;
398
399     PERL_ARGS_ASSERT_SAVE_HASH;
400
401     save_pushptrptr(
402         SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
403     );
404
405     GvHV(gv) = NULL;
406     hv = GvHVn(gv);
407     if (UNLIKELY(SvMAGIC(ohv)))
408         mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
409     return hv;
410 }
411
412 void
413 Perl_save_item(pTHX_ SV *item)
414 {
415     SV * const sv = newSVsv(item);
416
417     PERL_ARGS_ASSERT_SAVE_ITEM;
418
419     save_pushptrptr(item, /* remember the pointer */
420                     sv,   /* remember the value */
421                     SAVEt_ITEM);
422 }
423
424 void
425 Perl_save_bool(pTHX_ bool *boolp)
426 {
427     dSS_ADD;
428
429     PERL_ARGS_ASSERT_SAVE_BOOL;
430
431     SS_ADD_PTR(boolp);
432     SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
433     SS_ADD_END(2);
434 }
435
436 void
437 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
438 {
439     dSS_ADD;
440
441     SS_ADD_INT(i);
442     SS_ADD_PTR(ptr);
443     SS_ADD_UV(type);
444     SS_ADD_END(3);
445 }
446
447 void
448 Perl_save_int(pTHX_ int *intp)
449 {
450     const int i = *intp;
451     UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
452     int size = 2;
453     dSS_ADD;
454
455     PERL_ARGS_ASSERT_SAVE_INT;
456
457     if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) {
458         SS_ADD_INT(i);
459         type = SAVEt_INT;
460         size++;
461     }
462     SS_ADD_PTR(intp);
463     SS_ADD_UV(type);
464     SS_ADD_END(size);
465 }
466
467 void
468 Perl_save_I8(pTHX_ I8 *bytep)
469 {
470     dSS_ADD;
471
472     PERL_ARGS_ASSERT_SAVE_I8;
473
474     SS_ADD_PTR(bytep);
475     SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
476     SS_ADD_END(2);
477 }
478
479 void
480 Perl_save_I16(pTHX_ I16 *intp)
481 {
482     dSS_ADD;
483
484     PERL_ARGS_ASSERT_SAVE_I16;
485
486     SS_ADD_PTR(intp);
487     SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
488     SS_ADD_END(2);
489 }
490
491 void
492 Perl_save_I32(pTHX_ I32 *intp)
493 {
494     const I32 i = *intp;
495     UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
496     int size = 2;
497     dSS_ADD;
498
499     PERL_ARGS_ASSERT_SAVE_I32;
500
501     if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
502         SS_ADD_INT(i);
503         type = SAVEt_I32;
504         size++;
505     }
506     SS_ADD_PTR(intp);
507     SS_ADD_UV(type);
508     SS_ADD_END(size);
509 }
510
511 void
512 Perl_save_strlen(pTHX_ STRLEN *ptr)
513 {
514     dSS_ADD;
515
516     PERL_ARGS_ASSERT_SAVE_STRLEN;
517
518     SS_ADD_IV(*ptr);
519     SS_ADD_PTR(ptr);
520     SS_ADD_UV(SAVEt_STRLEN);
521     SS_ADD_END(3);
522 }
523
524 void
525 Perl_save_iv(pTHX_ IV *ivp)
526 {
527     PERL_ARGS_ASSERT_SAVE_IV;
528
529     SSCHECK(3);
530     SSPUSHIV(*ivp);
531     SSPUSHPTR(ivp);
532     SSPUSHUV(SAVEt_IV);
533 }
534
535 /* Cannot use save_sptr() to store a char* since the SV** cast will
536  * force word-alignment and we'll miss the pointer.
537  */
538 void
539 Perl_save_pptr(pTHX_ char **pptr)
540 {
541     PERL_ARGS_ASSERT_SAVE_PPTR;
542
543     save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
544 }
545
546 void
547 Perl_save_vptr(pTHX_ void *ptr)
548 {
549     PERL_ARGS_ASSERT_SAVE_VPTR;
550
551     save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
552 }
553
554 void
555 Perl_save_sptr(pTHX_ SV **sptr)
556 {
557     PERL_ARGS_ASSERT_SAVE_SPTR;
558
559     save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
560 }
561
562 void
563 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
564 {
565     dSS_ADD;
566
567     ASSERT_CURPAD_ACTIVE("save_padsv");
568     SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
569     SS_ADD_PTR(PL_comppad);
570     SS_ADD_UV((UV)off);
571     SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
572     SS_ADD_END(4);
573 }
574
575 void
576 Perl_save_hptr(pTHX_ HV **hptr)
577 {
578     PERL_ARGS_ASSERT_SAVE_HPTR;
579
580     save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
581 }
582
583 void
584 Perl_save_aptr(pTHX_ AV **aptr)
585 {
586     PERL_ARGS_ASSERT_SAVE_APTR;
587
588     save_pushptrptr(*aptr, aptr, SAVEt_APTR);
589 }
590
591 void
592 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
593 {
594     dSS_ADD;
595     SS_ADD_PTR(ptr);
596     SS_ADD_UV(type);
597     SS_ADD_END(2);
598 }
599
600 void
601 Perl_save_clearsv(pTHX_ SV **svp)
602 {
603     const UV offset = svp - PL_curpad;
604     const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
605
606     PERL_ARGS_ASSERT_SAVE_CLEARSV;
607
608     ASSERT_CURPAD_ACTIVE("save_clearsv");
609     SvPADSTALE_off(*svp); /* mark lexical as active */
610     if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) {
611         Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)",
612                    offset, svp, PL_curpad);
613     }
614
615     {
616         dSS_ADD;
617         SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
618         SS_ADD_END(1);
619     }
620 }
621
622 void
623 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
624 {
625     PERL_ARGS_ASSERT_SAVE_DELETE;
626
627     save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
628 }
629
630 void
631 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
632 {
633     STRLEN len;
634     I32 klen;
635     const char *key;
636
637     PERL_ARGS_ASSERT_SAVE_HDELETE;
638
639     key  = SvPV_const(keysv, len);
640     klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
641     SvREFCNT_inc_simple_void_NN(hv);
642     save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
643 }
644
645 void
646 Perl_save_adelete(pTHX_ AV *av, SSize_t key)
647 {
648     dSS_ADD;
649
650     PERL_ARGS_ASSERT_SAVE_ADELETE;
651
652     SvREFCNT_inc_void(av);
653     SS_ADD_UV(key);
654     SS_ADD_PTR(av);
655     SS_ADD_IV(SAVEt_ADELETE);
656     SS_ADD_END(3);
657 }
658
659 void
660 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
661 {
662     dSS_ADD;
663     PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
664
665     SS_ADD_DPTR(f);
666     SS_ADD_PTR(p);
667     SS_ADD_UV(SAVEt_DESTRUCTOR);
668     SS_ADD_END(3);
669 }
670
671 void
672 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
673 {
674     dSS_ADD;
675
676     SS_ADD_DXPTR(f);
677     SS_ADD_PTR(p);
678     SS_ADD_UV(SAVEt_DESTRUCTOR_X);
679     SS_ADD_END(3);
680 }
681
682 void
683 Perl_save_hints(pTHX)
684 {
685     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
686     if (PL_hints & HINT_LOCALIZE_HH) {
687         HV *oldhh = GvHV(PL_hintgv);
688         save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
689         GvHV(PL_hintgv) = NULL; /* in case copying dies */
690         GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
691     } else {
692         save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
693     }
694 }
695
696 static void
697 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
698                         const int type)
699 {
700     dSS_ADD;
701     SS_ADD_PTR(ptr1);
702     SS_ADD_INT(i);
703     SS_ADD_PTR(ptr2);
704     SS_ADD_UV(type);
705     SS_ADD_END(4);
706 }
707
708 void
709 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr,
710                             const U32 flags)
711 {
712     dSS_ADD;
713     SV *sv;
714
715     PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
716
717     SvGETMAGIC(*sptr);
718     SS_ADD_PTR(SvREFCNT_inc_simple(av));
719     SS_ADD_IV(idx);
720     SS_ADD_PTR(SvREFCNT_inc(*sptr));
721     SS_ADD_UV(SAVEt_AELEM);
722     SS_ADD_END(4);
723     /* The array needs to hold a reference count on its new element, so it
724        must be AvREAL. */
725     if (UNLIKELY(!AvREAL(av) && AvREIFY(av)))
726         av_reify(av);
727     save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
728     if (flags & SAVEf_KEEPOLDELEM)
729         return;
730     sv = *sptr;
731     /* If we're localizing a tied array element, this new sv
732      * won't actually be stored in the array - so it won't get
733      * reaped when the localize ends. Ensure it gets reaped by
734      * mortifying it instead. DAPM */
735     if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied)))
736         sv_2mortal(sv);
737 }
738
739 void
740 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
741 {
742     SV *sv;
743
744     PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
745
746     SvGETMAGIC(*sptr);
747     {
748         dSS_ADD;
749         SS_ADD_PTR(SvREFCNT_inc_simple(hv));
750         SS_ADD_PTR(newSVsv(key));
751         SS_ADD_PTR(SvREFCNT_inc(*sptr));
752         SS_ADD_UV(SAVEt_HELEM);
753         SS_ADD_END(4);
754     }
755     save_scalar_at(sptr, flags);
756     if (flags & SAVEf_KEEPOLDELEM)
757         return;
758     sv = *sptr;
759     /* If we're localizing a tied hash element, this new sv
760      * won't actually be stored in the hash - so it won't get
761      * reaped when the localize ends. Ensure it gets reaped by
762      * mortifying it instead. DAPM */
763     if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)))
764         sv_2mortal(sv);
765 }
766
767 SV*
768 Perl_save_svref(pTHX_ SV **sptr)
769 {
770     PERL_ARGS_ASSERT_SAVE_SVREF;
771
772     SvGETMAGIC(*sptr);
773     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
774     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
775 }
776
777
778 void
779 Perl_savetmps(pTHX)
780 {
781     dSS_ADD;
782     SS_ADD_IV(PL_tmps_floor);
783     PL_tmps_floor = PL_tmps_ix;
784     SS_ADD_UV(SAVEt_TMPSFLOOR);
785     SS_ADD_END(2);
786 }
787
788
789 I32
790 Perl_save_alloc(pTHX_ I32 size, I32 pad)
791 {
792     const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
793                           - (char*)PL_savestack);
794     const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
795     const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
796
797     if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems))
798         Perl_croak(aTHX_
799             "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")",
800                    elems, (IV)size, (IV)pad);
801
802     SSGROW(elems + 1);
803
804     PL_savestack_ix += elems;
805     SSPUSHUV(SAVEt_ALLOC | elems_shifted);
806     return start;
807 }
808
809
810 static const U8 arg_counts[] = {
811     0, /* SAVEt_ALLOC              */
812     0, /* SAVEt_CLEARPADRANGE      */
813     0, /* SAVEt_CLEARSV            */
814     0, /* SAVEt_REGCONTEXT         */
815     1, /* SAVEt_TMPSFLOOR          */
816     1, /* SAVEt_BOOL               */
817     1, /* SAVEt_COMPILE_WARNINGS   */
818     1, /* SAVEt_COMPPAD            */
819     1, /* SAVEt_FREECOPHH          */
820     1, /* SAVEt_FREEOP             */
821     1, /* SAVEt_FREEPV             */
822     1, /* SAVEt_FREESV             */
823     1, /* SAVEt_I16                */
824     1, /* SAVEt_I32_SMALL          */
825     1, /* SAVEt_I8                 */
826     1, /* SAVEt_INT_SMALL          */
827     1, /* SAVEt_MORTALIZESV        */
828     1, /* SAVEt_NSTAB              */
829     1, /* SAVEt_OP                 */
830     1, /* SAVEt_PARSER             */
831     1, /* SAVEt_STACK_POS          */
832     1, /* SAVEt_READONLY_OFF       */
833     1, /* SAVEt_FREEPADNAME        */
834     2, /* SAVEt_AV                 */
835     2, /* SAVEt_DESTRUCTOR         */
836     2, /* SAVEt_DESTRUCTOR_X       */
837     2, /* SAVEt_GENERIC_PVREF      */
838     2, /* SAVEt_GENERIC_SVREF      */
839     2, /* SAVEt_GP                 */
840     2, /* SAVEt_GVSV               */
841     2, /* SAVEt_HINTS              */
842     2, /* SAVEt_HPTR               */
843     2, /* SAVEt_HV                 */
844     2, /* SAVEt_I32                */
845     2, /* SAVEt_INT                */
846     2, /* SAVEt_ITEM               */
847     2, /* SAVEt_IV                 */
848     2, /* SAVEt_LONG               */
849     2, /* SAVEt_PPTR               */
850     2, /* SAVEt_SAVESWITCHSTACK    */
851     2, /* SAVEt_SHARED_PVREF       */
852     2, /* SAVEt_SPTR               */
853     2, /* SAVEt_STRLEN             */
854     2, /* SAVEt_SV                 */
855     2, /* SAVEt_SVREF              */
856     2, /* SAVEt_VPTR               */
857     2, /* SAVEt_ADELETE            */
858     2, /* SAVEt_APTR               */
859     3, /* SAVEt_HELEM              */
860     3, /* SAVEt_PADSV_AND_MORTALIZE*/
861     3, /* SAVEt_SET_SVFLAGS        */
862     3, /* SAVEt_GVSLOT             */
863     3, /* SAVEt_AELEM              */
864     3  /* SAVEt_DELETE             */
865 };
866
867
868 void
869 Perl_leave_scope(pTHX_ I32 base)
870 {
871     /* Localise the effects of the TAINT_NOT inside the loop.  */
872     bool was = TAINT_get;
873
874     if (UNLIKELY(base < -1))
875         Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
876     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
877                         (long)PL_savestack_ix, (long)base));
878     while (PL_savestack_ix > base) {
879         UV uv;
880         U8 type;
881         ANY *ap; /* arg pointer */
882         ANY a0, a1, a2; /* up to 3 args */
883
884         TAINT_NOT;
885
886         {
887             U8  argcount;
888             I32 ix = PL_savestack_ix - 1;
889
890             ap = &PL_savestack[ix];
891             uv = ap->any_uv;
892             type = (U8)uv & SAVE_MASK;
893             argcount = arg_counts[type];
894             PL_savestack_ix = ix - argcount;
895             ap -= argcount;
896         }
897
898         switch (type) {
899         case SAVEt_ITEM:                        /* normal string */
900             a0 = ap[0]; a1 = ap[1];
901             sv_replace(a0.any_sv, a1.any_sv);
902             if (UNLIKELY(SvSMAGICAL(a0.any_sv))) {
903                 PL_localizing = 2;
904                 mg_set(a0.any_sv);
905                 PL_localizing = 0;
906             }
907             break;
908
909             /* This would be a mathom, but Perl_save_svref() calls a static
910                function, S_save_scalar_at(), so has to stay in this file.  */
911         case SAVEt_SVREF:                       /* scalar reference */
912             a0 = ap[0]; a1 = ap[1];
913             a2.any_svp = a0.any_svp;
914             a0.any_sv = NULL; /* what to refcnt_dec */
915             goto restore_sv;
916
917         case SAVEt_SV:                          /* scalar reference */
918             a0 = ap[0]; a1 = ap[1];
919             a2.any_svp = &GvSV(a0.any_gv);
920         restore_sv:
921         {
922             /* do *a2.any_svp = a1 and free a0 */
923             SV * const sv = *a2.any_svp;
924             *a2.any_svp = a1.any_sv;
925             SvREFCNT_dec(sv);
926             if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
927                 /* mg_set could die, skipping the freeing of a0 and
928                  * a1; Ensure that they're always freed in that case */
929                 dSS_ADD;
930                 SS_ADD_PTR(a1.any_sv);
931                 SS_ADD_UV(SAVEt_FREESV);
932                 SS_ADD_PTR(a0.any_sv);
933                 SS_ADD_UV(SAVEt_FREESV);
934                 SS_ADD_END(4);
935                 PL_localizing = 2;
936                 mg_set(a1.any_sv);
937                 PL_localizing = 0;
938                 break;
939             }
940             SvREFCNT_dec_NN(a1.any_sv);
941             SvREFCNT_dec(a0.any_sv);
942             break;
943         }
944
945         case SAVEt_GENERIC_PVREF:               /* generic pv */
946             a0 = ap[0]; a1 = ap[1];
947             if (*a1.any_pvp != a0.any_pv) {
948                 Safefree(*a1.any_pvp);
949                 *a1.any_pvp = a0.any_pv;
950             }
951             break;
952
953         case SAVEt_SHARED_PVREF:                /* shared pv */
954             a0 = ap[0]; a1 = ap[1];
955             if (*a0.any_pvp != a1.any_pv) {
956 #ifdef NETWARE
957                 PerlMem_free(*a0.any_pvp);
958 #else
959                 PerlMemShared_free(*a0.any_pvp);
960 #endif
961                 *a0.any_pvp = a1.any_pv;
962             }
963             break;
964
965         case SAVEt_GVSV:                        /* scalar slot in GV */
966             a0 = ap[0]; a1 = ap[1];
967             a0.any_svp = &GvSV(a0.any_gv);
968             goto restore_svp;
969
970         case SAVEt_GENERIC_SVREF:               /* generic sv */
971             a0 = ap[0]; a1 = ap[1];
972         restore_svp:
973         {
974             /* do *a0.any_svp = a1 */
975             SV * const sv = *a0.any_svp;
976             *a0.any_svp = a1.any_sv;
977             SvREFCNT_dec(sv);
978             SvREFCNT_dec(a1.any_sv);
979             break;
980         }
981
982         case SAVEt_GVSLOT:                      /* any slot in GV */
983         {
984             HV * hv;
985             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
986             hv = GvSTASH(a0.any_gv);
987             if (hv && HvENAME(hv) && (
988                     (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV)
989                  || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV)
990                ))
991             {
992                 if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv)
993                  || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp)
994                  || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */
995                     PL_sub_generation++;
996                 else mro_method_changed_in(hv);
997             }
998             a0.any_svp = a1.any_svp;
999             a1.any_sv  = a2.any_sv;
1000             goto restore_svp;
1001         }
1002
1003         case SAVEt_AV:                          /* array reference */
1004             a0 = ap[0]; a1 = ap[1];
1005             SvREFCNT_dec(GvAV(a0.any_gv));
1006             GvAV(a0.any_gv) = a1.any_av;
1007           avhv_common:
1008             if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1009                 /* mg_set might die, so make sure a0 isn't leaked */
1010                 dSS_ADD;
1011                 SS_ADD_PTR(a0.any_sv);
1012                 SS_ADD_UV(SAVEt_FREESV);
1013                 SS_ADD_END(2);
1014                 PL_localizing = 2;
1015                 mg_set(a1.any_sv);
1016                 PL_localizing = 0;
1017                 break;
1018             }
1019             SvREFCNT_dec_NN(a0.any_sv);
1020             break;
1021
1022         case SAVEt_HV:                          /* hash reference */
1023             a0 = ap[0]; a1 = ap[1];
1024             SvREFCNT_dec(GvHV(a0.any_gv));
1025             GvHV(a0.any_gv) = a1.any_hv;
1026             goto avhv_common;
1027
1028         case SAVEt_INT_SMALL:
1029             a0 = ap[0];
1030             *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
1031             break;
1032
1033         case SAVEt_INT:                         /* int reference */
1034             a0 = ap[0]; a1 = ap[1];
1035             *(int*)a1.any_ptr = (int)a0.any_i32;
1036             break;
1037
1038         case SAVEt_STRLEN:                      /* STRLEN/size_t ref */
1039             a0 = ap[0]; a1 = ap[1];
1040             *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv;
1041             break;
1042
1043         case SAVEt_TMPSFLOOR:                   /* restore PL_tmps_floor */
1044             a0 = ap[0];
1045             PL_tmps_floor = (SSize_t)a0.any_iv;
1046             break;
1047
1048         case SAVEt_BOOL:                        /* bool reference */
1049             a0 = ap[0];
1050             *(bool*)a0.any_ptr = cBOOL(uv >> 8);
1051 #ifdef NO_TAINT_SUPPORT
1052             PERL_UNUSED_VAR(was);
1053 #else
1054             if (UNLIKELY(a0.any_ptr == &(TAINT_get))) {
1055                 /* If we don't update <was>, to reflect what was saved on the
1056                  * stack for PL_tainted, then we will overwrite this attempt to
1057                  * restore it when we exit this routine.  Note that this won't
1058                  * work if this value was saved in a wider-than necessary type,
1059                  * such as I32 */
1060                 was = *(bool*)a0.any_ptr;
1061             }
1062 #endif
1063             break;
1064
1065         case SAVEt_I32_SMALL:
1066             a0 = ap[0];
1067             *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
1068             break;
1069
1070         case SAVEt_I32:                         /* I32 reference */
1071             a0 = ap[0]; a1 = ap[1];
1072 #ifdef PERL_DEBUG_READONLY_OPS
1073             if (*(I32*)a1.any_ptr != a0.any_i32)
1074 #endif
1075                 *(I32*)a1.any_ptr = a0.any_i32;
1076             break;
1077
1078         case SAVEt_SPTR:                        /* SV* reference */
1079         case SAVEt_VPTR:                        /* random* reference */
1080         case SAVEt_PPTR:                        /* char* reference */
1081         case SAVEt_HPTR:                        /* HV* reference */
1082         case SAVEt_APTR:                        /* AV* reference */
1083             a0 = ap[0]; a1 = ap[1];
1084             *a1.any_svp= a0.any_sv;
1085             break;
1086
1087         case SAVEt_GP:                          /* scalar reference */
1088         {
1089             HV *hv;
1090             bool had_method;
1091
1092             a0 = ap[0]; a1 = ap[1];
1093             /* possibly taking a method out of circulation */   
1094             had_method = !!GvCVu(a0.any_gv);
1095             gp_free(a0.any_gv);
1096             GvGP_set(a0.any_gv, (GP*)a1.any_ptr);
1097             if ((hv=GvSTASH(a0.any_gv)) && HvENAME_get(hv)) {
1098                 if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA"))
1099                     mro_isa_changed_in(hv);
1100                 else if (had_method || GvCVu(a0.any_gv))
1101                     /* putting a method back into circulation ("local")*/       
1102                     gv_method_changed(a0.any_gv);
1103             }
1104             SvREFCNT_dec_NN(a0.any_gv);
1105             break;
1106         }
1107
1108         case SAVEt_FREESV:
1109             a0 = ap[0];
1110             SvREFCNT_dec(a0.any_sv);
1111             break;
1112
1113         case SAVEt_FREEPADNAME:
1114             a0 = ap[0];
1115             PadnameREFCNT_dec((PADNAME *)a0.any_ptr);
1116             break;
1117
1118         case SAVEt_FREECOPHH:
1119             a0 = ap[0];
1120             cophh_free((COPHH *)a0.any_ptr);
1121             break;
1122
1123         case SAVEt_MORTALIZESV:
1124             a0 = ap[0];
1125             sv_2mortal(a0.any_sv);
1126             break;
1127
1128         case SAVEt_FREEOP:
1129             a0 = ap[0];
1130             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
1131             op_free(a0.any_op);
1132             break;
1133
1134         case SAVEt_FREEPV:
1135             a0 = ap[0];
1136             Safefree(a0.any_ptr);
1137             break;
1138
1139         case SAVEt_CLEARPADRANGE:
1140         {
1141             I32 i;
1142             SV **svp;
1143             i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1144             svp = &PL_curpad[uv >>
1145                     (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1146             goto clearsv;
1147         case SAVEt_CLEARSV:
1148             svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1149             i = 1;
1150           clearsv:
1151             for (; i; i--, svp--) {
1152                 SV *sv = *svp;
1153
1154                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1155              "Pad 0x%" UVxf "[0x%" UVxf "] clearsv: %ld sv=0x%" UVxf "<%" IVdf "> %s\n",
1156                     PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1157                     (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1158                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1159                 ));
1160
1161                 /* Can clear pad variable in place? */
1162                 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
1163
1164                     /* these flags are the union of all the relevant flags
1165                      * in the individual conditions within */
1166                     if (UNLIKELY(SvFLAGS(sv) & (
1167                             SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
1168                           | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
1169                           | SVf_OOK
1170                           | SVf_THINKFIRST)))
1171                     {
1172                         /* if a my variable that was made readonly is
1173                          * going out of scope, we want to remove the
1174                          * readonlyness so that it can go out of scope
1175                          * quietly
1176                          */
1177                         if (SvREADONLY(sv))
1178                             SvREADONLY_off(sv);
1179
1180                         if (SvOOK(sv)) { /* OOK or HvAUX */
1181                             if (SvTYPE(sv) == SVt_PVHV)
1182                                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1183                             else
1184                                 sv_backoff(sv);
1185                         }
1186
1187                         if (SvMAGICAL(sv)) {
1188                             /* note that backrefs (either in HvAUX or magic)
1189                              * must be removed before other magic */
1190                             sv_unmagic(sv, PERL_MAGIC_backref);
1191                             if (SvTYPE(sv) != SVt_PVCV)
1192                                 mg_free(sv);
1193                         }
1194                         if (SvTHINKFIRST(sv))
1195                             sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1196                                                      |SV_COW_DROP_PV);
1197
1198                     }
1199                     switch (SvTYPE(sv)) {
1200                     case SVt_NULL:
1201                         break;
1202                     case SVt_PVAV:
1203                         av_clear(MUTABLE_AV(sv));
1204                         break;
1205                     case SVt_PVHV:
1206                         hv_clear(MUTABLE_HV(sv));
1207                         break;
1208                     case SVt_PVCV:
1209                     {
1210                         HEK *hek = CvGvNAME_HEK(sv);
1211                         assert(hek);
1212                         (void)share_hek_hek(hek);
1213                         cv_undef((CV *)sv);
1214                         CvNAME_HEK_set(sv, hek);
1215                         CvLEXICAL_on(sv);
1216                         break;
1217                     }
1218                     default:
1219                         /* This looks odd, but these two macros are for use in
1220                            expressions and finish with a trailing comma, so
1221                            adding a ; after them would be wrong. */
1222                         assert_not_ROK(sv)
1223                         assert_not_glob(sv)
1224                         SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
1225                         break;
1226                     }
1227                     SvPADTMP_off(sv);
1228                     SvPADSTALE_on(sv); /* mark as no longer live */
1229                 }
1230                 else {  /* Someone has a claim on this, so abandon it. */
1231                     switch (SvTYPE(sv)) {       /* Console ourselves with a new value */
1232                     case SVt_PVAV:      *svp = MUTABLE_SV(newAV());     break;
1233                     case SVt_PVHV:      *svp = MUTABLE_SV(newHV());     break;
1234                     case SVt_PVCV:
1235                     {
1236                         HEK * const hek = CvGvNAME_HEK(sv);
1237
1238                         /* Create a stub */
1239                         *svp = newSV_type(SVt_PVCV);
1240
1241                         /* Share name */
1242                         CvNAME_HEK_set(*svp,
1243                                        share_hek_hek(hek));
1244                         CvLEXICAL_on(*svp);
1245                         break;
1246                     }
1247                     default:    *svp = newSV(0);                break;
1248                     }
1249                     SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1250                     /* preserve pad nature, but also mark as not live
1251                      * for any closure capturing */
1252                     SvFLAGS(*svp) |= SVs_PADSTALE;
1253                 }
1254             }
1255             break;
1256         }
1257
1258         case SAVEt_DELETE:
1259             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1260             /* hv_delete could die, so free the key and SvREFCNT_dec the
1261              * hv by pushing new save actions
1262              */
1263             /* ap[0] is the key */
1264             ap[1].any_uv = SAVEt_FREEPV; /* was len */
1265             /* ap[2] is the hv */
1266             ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */
1267             PL_savestack_ix += 4;
1268             (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD);
1269             break;
1270
1271         case SAVEt_ADELETE:
1272             a0 = ap[0]; a1 = ap[1];
1273             /* av_delete could die, so SvREFCNT_dec the av by pushing a
1274              * new save action
1275              */
1276             ap[0].any_av = a1.any_av;
1277             ap[1].any_uv = SAVEt_FREESV;
1278             PL_savestack_ix += 2;
1279             (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD);
1280             break;
1281
1282         case SAVEt_DESTRUCTOR_X:
1283             a0 = ap[0]; a1 = ap[1];
1284             (*a0.any_dxptr)(aTHX_ a1.any_ptr);
1285             break;
1286
1287         case SAVEt_REGCONTEXT:
1288             /* regexp must have croaked */
1289         case SAVEt_ALLOC:
1290             PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1291             break;
1292
1293         case SAVEt_STACK_POS:           /* Position on Perl stack */
1294             a0 = ap[0];
1295             PL_stack_sp = PL_stack_base + a0.any_i32;
1296             break;
1297
1298         case SAVEt_AELEM:               /* array element */
1299         {
1300             SV **svp;
1301             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1302             svp = av_fetch(a0.any_av, a1.any_iv, 1);
1303             if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */
1304                 SvREFCNT_dec(a2.any_sv);
1305             if (LIKELY(svp)) {
1306                 SV * const sv = *svp;
1307                 if (LIKELY(sv && sv != &PL_sv_undef)) {
1308                     if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied)))
1309                         SvREFCNT_inc_void_NN(sv);
1310                     a1.any_sv  = a2.any_sv;
1311                     a2.any_svp = svp;
1312                     goto restore_sv;
1313                 }
1314             }
1315             SvREFCNT_dec(a0.any_av);
1316             SvREFCNT_dec(a2.any_sv);
1317             break;
1318         }
1319
1320         case SAVEt_HELEM:               /* hash element */
1321         {
1322             HE *he;
1323
1324             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1325             he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0);
1326             SvREFCNT_dec(a1.any_sv);
1327             if (LIKELY(he)) {
1328                 const SV * const oval = HeVAL(he);
1329                 if (LIKELY(oval && oval != &PL_sv_undef)) {
1330                     SV **svp = &HeVAL(he);
1331                     if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied)))
1332                         SvREFCNT_inc_void(*svp);
1333                     a1.any_sv  = a2.any_sv;
1334                     a2.any_svp = svp;
1335                     goto restore_sv;
1336                 }
1337             }
1338             SvREFCNT_dec(a0.any_hv);
1339             SvREFCNT_dec(a2.any_sv);
1340             break;
1341         }
1342
1343         case SAVEt_OP:
1344             a0 = ap[0];
1345             PL_op = (OP*)a0.any_ptr;
1346             break;
1347
1348         case SAVEt_HINTS:
1349             a0 = ap[0]; a1 = ap[1];
1350             if ((PL_hints & HINT_LOCALIZE_HH)) {
1351               while (GvHV(PL_hintgv)) {
1352                 HV *hv = GvHV(PL_hintgv);
1353                 GvHV(PL_hintgv) = NULL;
1354                 SvREFCNT_dec(MUTABLE_SV(hv));
1355               }
1356             }
1357             cophh_free(CopHINTHASH_get(&PL_compiling));
1358             CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr);
1359             *(I32*)&PL_hints = a0.any_i32;
1360             if (PL_hints & HINT_LOCALIZE_HH) {
1361                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1362                 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
1363             }
1364             if (!GvHV(PL_hintgv)) {
1365                 /* Need to add a new one manually, else rv2hv can
1366                    add one via GvHVn and it won't have the magic set.  */
1367                 HV *const hv = newHV();
1368                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1369                 GvHV(PL_hintgv) = hv;
1370             }
1371             assert(GvHV(PL_hintgv));
1372             break;
1373
1374         case SAVEt_COMPPAD:
1375             a0 = ap[0];
1376             PL_comppad = (PAD*)a0.any_ptr;
1377             if (LIKELY(PL_comppad))
1378                 PL_curpad = AvARRAY(PL_comppad);
1379             else
1380                 PL_curpad = NULL;
1381             break;
1382
1383         case SAVEt_PADSV_AND_MORTALIZE:
1384             {
1385                 SV **svp;
1386
1387                 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1388                 assert (a1.any_ptr);
1389                 svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv;
1390                 /* This mortalizing used to be done by CX_POOPLOOP() via
1391                    itersave.  But as we have all the information here, we
1392                    can do it here, save even having to have itersave in
1393                    the struct.
1394                    */
1395                 sv_2mortal(*svp);
1396                 *svp = a0.any_sv;
1397             }
1398             break;
1399
1400         case SAVEt_SAVESWITCHSTACK:
1401             {
1402                 dSP;
1403
1404                 a0 = ap[0]; a1 = ap[1];
1405                 SWITCHSTACK(a1.any_av, a0.any_av);
1406                 PL_curstackinfo->si_stack = a0.any_av;
1407             }
1408             break;
1409
1410         case SAVEt_SET_SVFLAGS:
1411             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1412             SvFLAGS(a0.any_sv) &= ~(a1.any_u32);
1413             SvFLAGS(a0.any_sv) |= a2.any_u32;
1414             break;
1415
1416             /* These are only saved in mathoms.c */
1417         case SAVEt_NSTAB:
1418             a0 = ap[0];
1419             (void)sv_clear(a0.any_sv);
1420             break;
1421
1422         case SAVEt_LONG:                        /* long reference */
1423             a0 = ap[0]; a1 = ap[1];
1424             *(long*)a1.any_ptr = a0.any_long;
1425             break;
1426
1427         case SAVEt_IV:                          /* IV reference */
1428             a0 = ap[0]; a1 = ap[1];
1429             *(IV*)a1.any_ptr = a0.any_iv;
1430             break;
1431
1432         case SAVEt_I16:                         /* I16 reference */
1433             a0 = ap[0];
1434             *(I16*)a0.any_ptr = (I16)(uv >> 8);
1435             break;
1436
1437         case SAVEt_I8:                          /* I8 reference */
1438             a0 = ap[0];
1439             *(I8*)a0.any_ptr = (I8)(uv >> 8);
1440             break;
1441
1442         case SAVEt_DESTRUCTOR:
1443             a0 = ap[0]; a1 = ap[1];
1444             (*a0.any_dptr)(a1.any_ptr);
1445             break;
1446
1447         case SAVEt_COMPILE_WARNINGS:
1448             a0 = ap[0];
1449             if (!specialWARN(PL_compiling.cop_warnings))
1450                 PerlMemShared_free(PL_compiling.cop_warnings);
1451             PL_compiling.cop_warnings = (STRLEN*)a0.any_ptr;
1452             break;
1453
1454         case SAVEt_PARSER:
1455             a0 = ap[0];
1456             parser_free((yy_parser *)a0.any_ptr);
1457             break;
1458
1459         case SAVEt_READONLY_OFF:
1460             a0 = ap[0];
1461             SvREADONLY_off(a0.any_sv);
1462             break;
1463
1464         default:
1465             Perl_croak(aTHX_ "panic: leave_scope inconsistency %u",
1466                     (U8)uv & SAVE_MASK);
1467         }
1468     }
1469
1470     TAINT_set(was);
1471 }
1472
1473 void
1474 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1475 {
1476     PERL_ARGS_ASSERT_CX_DUMP;
1477
1478 #ifdef DEBUGGING
1479     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1480     if (CxTYPE(cx) != CXt_SUBST) {
1481         const char *gimme_text;
1482         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1483         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n",
1484                       PTR2UV(cx->blk_oldcop));
1485         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1486         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1487         PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix);
1488         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n",
1489                       PTR2UV(cx->blk_oldpm));
1490         switch (cx->blk_gimme) {
1491             case G_VOID:
1492                 gimme_text = "VOID";
1493                 break;
1494             case G_SCALAR:
1495                 gimme_text = "SCALAR";
1496                 break;
1497             case G_ARRAY:
1498                 gimme_text = "LIST";
1499                 break;
1500             default:
1501                 gimme_text = "UNKNOWN";
1502                 break;
1503         }
1504         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1505     }
1506     switch (CxTYPE(cx)) {
1507     case CXt_NULL:
1508     case CXt_BLOCK:
1509         break;
1510     case CXt_FORMAT:
1511         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n",
1512                 PTR2UV(cx->blk_format.cv));
1513         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n",
1514                 PTR2UV(cx->blk_format.gv));
1515         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n",
1516                 PTR2UV(cx->blk_format.dfoutgv));
1517         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1518                       (int)CxHASARGS(cx));
1519         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n",
1520                 PTR2UV(cx->blk_format.retop));
1521         break;
1522     case CXt_SUB:
1523         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n",
1524                 PTR2UV(cx->blk_sub.cv));
1525         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1526                 (long)cx->blk_sub.olddepth);
1527         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1528                 (int)CxHASARGS(cx));
1529         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1530         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n",
1531                 PTR2UV(cx->blk_sub.retop));
1532         break;
1533     case CXt_EVAL:
1534         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1535                 (long)CxOLD_IN_EVAL(cx));
1536         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1537                 PL_op_name[CxOLD_OP_TYPE(cx)],
1538                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1539         if (cx->blk_eval.old_namesv)
1540             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1541                           SvPVX_const(cx->blk_eval.old_namesv));
1542         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n",
1543                 PTR2UV(cx->blk_eval.old_eval_root));
1544         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n",
1545                 PTR2UV(cx->blk_eval.retop));
1546         break;
1547
1548     case CXt_LOOP_PLAIN:
1549     case CXt_LOOP_LAZYIV:
1550     case CXt_LOOP_LAZYSV:
1551     case CXt_LOOP_LIST:
1552     case CXt_LOOP_ARY:
1553         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1554         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n",
1555                 PTR2UV(cx->blk_loop.my_op));
1556         if (CxTYPE(cx) != CXt_LOOP_PLAIN) {
1557             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n",
1558                     PTR2UV(CxITERVAR(cx)));
1559             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n",
1560                     PTR2UV(cx->blk_loop.itersave));
1561         }
1562         if (CxTYPE(cx) == CXt_LOOP_ARY) {
1563             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n",
1564                     PTR2UV(cx->blk_loop.state_u.ary.ary));
1565             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1566                     (long)cx->blk_loop.state_u.ary.ix);
1567         }
1568         break;
1569
1570     case CXt_SUBST:
1571         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1572                 (long)cx->sb_iters);
1573         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1574                 (long)cx->sb_maxiters);
1575         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1576                 (long)cx->sb_rflags);
1577         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1578                 (long)CxONCE(cx));
1579         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1580                 cx->sb_orig);
1581         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n",
1582                 PTR2UV(cx->sb_dstr));
1583         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n",
1584                 PTR2UV(cx->sb_targ));
1585         PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n",
1586                 PTR2UV(cx->sb_s));
1587         PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n",
1588                 PTR2UV(cx->sb_m));
1589         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n",
1590                 PTR2UV(cx->sb_strend));
1591         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n",
1592                 PTR2UV(cx->sb_rxres));
1593         break;
1594     }
1595 #else
1596     PERL_UNUSED_CONTEXT;
1597     PERL_UNUSED_ARG(cx);
1598 #endif  /* DEBUGGING */
1599 }
1600
1601 /*
1602  * ex: set ts=8 sts=4 sw=4 et:
1603  */