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