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