This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
markstack_grow(): fix debugging stuff
[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                 PL_localizing = 2;
845                 mg_set(ARG0_SV);
846                 PL_localizing = 0;
847             }
848             SvREFCNT_dec_NN(ARG0_SV);
849             SvREFCNT_dec(refsv);
850             break;
851         }
852         case SAVEt_GENERIC_PVREF:               /* generic pv */
853             if (*ARG0_PVP != ARG1_PV) {
854                 Safefree(*ARG0_PVP);
855                 *ARG0_PVP = ARG1_PV;
856             }
857             break;
858         case SAVEt_SHARED_PVREF:                /* shared pv */
859             if (*ARG1_PVP != ARG0_PV) {
860 #ifdef NETWARE
861                 PerlMem_free(*ARG1_PVP);
862 #else
863                 PerlMemShared_free(*ARG1_PVP);
864 #endif
865                 *ARG1_PVP = ARG0_PV;
866             }
867             break;
868         case SAVEt_GVSV:                        /* scalar slot in GV */
869             svp = &GvSV(ARG1_GV);
870             goto restore_svp;
871         case SAVEt_GENERIC_SVREF:               /* generic sv */
872             svp = ARG1_SVP;
873         restore_svp:
874         {
875             SV * const sv = *svp;
876             *svp = ARG0_SV;
877             SvREFCNT_dec(sv);
878             SvREFCNT_dec(ARG0_SV);
879             break;
880         }
881         case SAVEt_GVSLOT:                      /* any slot in GV */
882         {
883             HV *const hv = GvSTASH(ARG2_GV);
884             svp = ARG1_SVP;
885             if (hv && HvENAME(hv) && (
886                     (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
887                  || (*svp && SvTYPE(*svp) == SVt_PVCV)
888                ))
889             {
890                 if ((char *)svp < (char *)GvGP(ARG2_GV)
891                  || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
892                  || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */
893                     PL_sub_generation++;
894                 else mro_method_changed_in(hv);
895             }
896             goto restore_svp;
897         }
898         case SAVEt_AV:                          /* array reference */
899             SvREFCNT_dec(GvAV(ARG1_GV));
900             GvAV(ARG1_GV) = ARG0_AV;
901             if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
902                 PL_localizing = 2;
903                 mg_set(ARG0_SV);
904                 PL_localizing = 0;
905             }
906             SvREFCNT_dec_NN(ARG1_GV);
907             break;
908         case SAVEt_HV:                          /* hash reference */
909             SvREFCNT_dec(GvHV(ARG1_GV));
910             GvHV(ARG1_GV) = ARG0_HV;
911             if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
912                 PL_localizing = 2;
913                 mg_set(ARG0_SV);
914                 PL_localizing = 0;
915             }
916             SvREFCNT_dec_NN(ARG1_GV);
917             break;
918         case SAVEt_INT_SMALL:
919             *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
920             break;
921         case SAVEt_INT:                         /* int reference */
922             *(int*)ARG0_PTR = (int)ARG1_I32;
923             break;
924         case SAVEt_STRLEN:                      /* STRLEN/size_t ref */
925             *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv;
926             break;
927         case SAVEt_BOOL:                        /* bool reference */
928             *(bool*)ARG0_PTR = cBOOL(uv >> 8);
929 #ifdef NO_TAINT_SUPPORT
930             PERL_UNUSED_VAR(was);
931 #else
932             if (UNLIKELY(ARG0_PTR == &(TAINT_get))) {
933                 /* If we don't update <was>, to reflect what was saved on the
934                  * stack for PL_tainted, then we will overwrite this attempt to
935                  * restore it when we exit this routine.  Note that this won't
936                  * work if this value was saved in a wider-than necessary type,
937                  * such as I32 */
938                 was = *(bool*)ARG0_PTR;
939             }
940 #endif
941             break;
942         case SAVEt_I32_SMALL:
943             *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
944             break;
945         case SAVEt_I32:                         /* I32 reference */
946 #ifdef PERL_DEBUG_READONLY_OPS
947             if (*(I32*)ARG0_PTR != ARG1_I32)
948 #endif
949                 *(I32*)ARG0_PTR = ARG1_I32;
950             break;
951         case SAVEt_SPTR:                        /* SV* reference */
952             *(SV**)(ARG0_PTR)= ARG1_SV;
953             break;
954         case SAVEt_VPTR:                        /* random* reference */
955         case SAVEt_PPTR:                        /* char* reference */
956             *ARG0_PVP = ARG1_PV;
957             break;
958         case SAVEt_HPTR:                        /* HV* reference */
959             *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
960             break;
961         case SAVEt_APTR:                        /* AV* reference */
962             *(AV**)ARG0_PTR = ARG1_AV;
963             break;
964         case SAVEt_GP:                          /* scalar reference */
965         {
966             HV *hv;
967             /* possibly taking a method out of circulation */   
968             const bool had_method = !!GvCVu(ARG1_GV);
969             gp_free(ARG1_GV);
970             GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
971             if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
972                 if (   GvNAMELEN(ARG1_GV) == 3
973                     && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
974                 )
975                     mro_isa_changed_in(hv);
976                 else if (had_method || GvCVu(ARG1_GV))
977                     /* putting a method back into circulation ("local")*/       
978                     gv_method_changed(ARG1_GV);
979             }
980             SvREFCNT_dec_NN(ARG1_GV);
981             break;
982         }
983         case SAVEt_FREESV:
984             SvREFCNT_dec(ARG0_SV);
985             break;
986         case SAVEt_FREEPADNAME:
987             PadnameREFCNT_dec((PADNAME *)ARG0_PTR);
988             break;
989         case SAVEt_FREECOPHH:
990             cophh_free((COPHH *)ARG0_PTR);
991             break;
992         case SAVEt_MORTALIZESV:
993             sv_2mortal(ARG0_SV);
994             break;
995         case SAVEt_FREEOP:
996             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
997             op_free((OP*)ARG0_PTR);
998             break;
999         case SAVEt_FREEPV:
1000             Safefree(ARG0_PTR);
1001             break;
1002
1003         case SAVEt_CLEARPADRANGE:
1004             i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1005             svp = &PL_curpad[uv >>
1006                     (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1007             goto clearsv;
1008         case SAVEt_CLEARSV:
1009             svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1010             i = 1;
1011           clearsv:
1012             for (; i; i--, svp--) {
1013                 sv = *svp;
1014
1015                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1016              "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
1017                     PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1018                     (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1019                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1020                 ));
1021
1022                 /* Can clear pad variable in place? */
1023                 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
1024
1025                     /* these flags are the union of all the relevant flags
1026                      * in the individual conditions within */
1027                     if (UNLIKELY(SvFLAGS(sv) & (
1028                             SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
1029                           | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
1030                           | SVf_OOK
1031                           | SVf_THINKFIRST)))
1032                     {
1033                         /* if a my variable that was made readonly is
1034                          * going out of scope, we want to remove the
1035                          * readonlyness so that it can go out of scope
1036                          * quietly
1037                          */
1038                         if (SvREADONLY(sv))
1039                             SvREADONLY_off(sv);
1040
1041                         if (SvOOK(sv)) { /* OOK or HvAUX */
1042                             if (SvTYPE(sv) == SVt_PVHV)
1043                                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1044                             else
1045                                 sv_backoff(sv);
1046                         }
1047
1048                         if (SvMAGICAL(sv)) {
1049                             /* note that backrefs (either in HvAUX or magic)
1050                              * must be removed before other magic */
1051                             sv_unmagic(sv, PERL_MAGIC_backref);
1052                             if (SvTYPE(sv) != SVt_PVCV)
1053                                 mg_free(sv);
1054                         }
1055                         if (SvTHINKFIRST(sv))
1056                             sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1057                                                      |SV_COW_DROP_PV);
1058
1059                     }
1060                     switch (SvTYPE(sv)) {
1061                     case SVt_NULL:
1062                         break;
1063                     case SVt_PVAV:
1064                         av_clear(MUTABLE_AV(sv));
1065                         break;
1066                     case SVt_PVHV:
1067                         hv_clear(MUTABLE_HV(sv));
1068                         break;
1069                     case SVt_PVCV:
1070                     {
1071                         HEK *hek =
1072                               CvNAMED(sv)
1073                                 ? CvNAME_HEK((CV *)sv)
1074                                 : GvNAME_HEK(CvGV(sv));
1075                         assert(hek);
1076                         (void)share_hek_hek(hek);
1077                         cv_undef((CV *)sv);
1078                         CvNAME_HEK_set(sv, hek);
1079                         CvLEXICAL_on(sv);
1080                         break;
1081                     }
1082                     default:
1083                         /* This looks odd, but these two macros are for use in
1084                            expressions and finish with a trailing comma, so
1085                            adding a ; after them would be wrong. */
1086                         assert_not_ROK(sv)
1087                         assert_not_glob(sv)
1088                         SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
1089                         break;
1090                     }
1091                     SvPADTMP_off(sv);
1092                     SvPADSTALE_on(sv); /* mark as no longer live */
1093                 }
1094                 else {  /* Someone has a claim on this, so abandon it. */
1095                     switch (SvTYPE(sv)) {       /* Console ourselves with a new value */
1096                     case SVt_PVAV:      *svp = MUTABLE_SV(newAV());     break;
1097                     case SVt_PVHV:      *svp = MUTABLE_SV(newHV());     break;
1098                     case SVt_PVCV:
1099                     {
1100                         HEK * const hek = CvNAMED(sv)
1101                                              ? CvNAME_HEK((CV *)sv)
1102                                              : GvNAME_HEK(CvGV(sv));
1103
1104                         /* Create a stub */
1105                         *svp = newSV_type(SVt_PVCV);
1106
1107                         /* Share name */
1108                         CvNAME_HEK_set(*svp,
1109                                        share_hek_hek(hek));
1110                         CvLEXICAL_on(*svp);
1111                         break;
1112                     }
1113                     default:    *svp = newSV(0);                break;
1114                     }
1115                     SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1116                     /* preserve pad nature, but also mark as not live
1117                      * for any closure capturing */
1118                     SvFLAGS(*svp) |= SVs_PADSTALE;
1119                 }
1120             }
1121             break;
1122         case SAVEt_DELETE:
1123             (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
1124             SvREFCNT_dec(ARG0_HV);
1125             Safefree(arg2.any_ptr);
1126             break;
1127         case SAVEt_ADELETE:
1128             (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD);
1129             SvREFCNT_dec(ARG0_AV);
1130             break;
1131         case SAVEt_DESTRUCTOR_X:
1132             (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
1133             break;
1134         case SAVEt_REGCONTEXT:
1135             /* regexp must have croaked */
1136         case SAVEt_ALLOC:
1137             PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1138             break;
1139         case SAVEt_STACK_POS:           /* Position on Perl stack */
1140             PL_stack_sp = PL_stack_base + arg0.any_i32;
1141             break;
1142         case SAVEt_AELEM:               /* array element */
1143             svp = av_fetch(ARG2_AV, arg1.any_iv, 1);
1144             if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */
1145                 SvREFCNT_dec(ARG0_SV);
1146             if (LIKELY(svp)) {
1147                 SV * const sv = *svp;
1148                 if (LIKELY(sv && sv != &PL_sv_undef)) {
1149                     if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied)))
1150                         SvREFCNT_inc_void_NN(sv);
1151                     refsv = ARG2_SV;
1152                     goto restore_sv;
1153                 }
1154             }
1155             SvREFCNT_dec(ARG2_AV);
1156             SvREFCNT_dec(ARG0_SV);
1157             break;
1158         case SAVEt_HELEM:               /* hash element */
1159         {
1160             HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
1161             SvREFCNT_dec(ARG1_SV);
1162             if (LIKELY(he)) {
1163                 const SV * const oval = HeVAL(he);
1164                 if (LIKELY(oval && oval != &PL_sv_undef)) {
1165                     svp = &HeVAL(he);
1166                     if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied)))
1167                         SvREFCNT_inc_void(*svp);
1168                     refsv = ARG2_SV; /* what to refcnt_dec */
1169                     goto restore_sv;
1170                 }
1171             }
1172             SvREFCNT_dec(ARG2_HV);
1173             SvREFCNT_dec(ARG0_SV);
1174             break;
1175         }
1176         case SAVEt_OP:
1177             PL_op = (OP*)ARG0_PTR;
1178             break;
1179         case SAVEt_HINTS:
1180             if ((PL_hints & HINT_LOCALIZE_HH)) {
1181               while (GvHV(PL_hintgv)) {
1182                 HV *hv = GvHV(PL_hintgv);
1183                 GvHV(PL_hintgv) = NULL;
1184                 SvREFCNT_dec(MUTABLE_SV(hv));
1185               }
1186             }
1187             cophh_free(CopHINTHASH_get(&PL_compiling));
1188             CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
1189             *(I32*)&PL_hints = ARG1_I32;
1190             if (PL_hints & HINT_LOCALIZE_HH) {
1191                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1192                 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
1193             }
1194             if (!GvHV(PL_hintgv)) {
1195                 /* Need to add a new one manually, else rv2hv can
1196                    add one via GvHVn and it won't have the magic set.  */
1197                 HV *const hv = newHV();
1198                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1199                 GvHV(PL_hintgv) = hv;
1200             }
1201             assert(GvHV(PL_hintgv));
1202             break;
1203         case SAVEt_COMPPAD:
1204             PL_comppad = (PAD*)ARG0_PTR;
1205             if (LIKELY(PL_comppad))
1206                 PL_curpad = AvARRAY(PL_comppad);
1207             else
1208                 PL_curpad = NULL;
1209             break;
1210         case SAVEt_PADSV_AND_MORTALIZE:
1211             {
1212                 SV **svp;
1213                 assert (ARG1_PTR);
1214                 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
1215                 /* This mortalizing used to be done by POPLOOP() via itersave.
1216                    But as we have all the information here, we can do it here,
1217                    save even having to have itersave in the struct.  */
1218                 sv_2mortal(*svp);
1219                 *svp = ARG2_SV;
1220             }
1221             break;
1222         case SAVEt_SAVESWITCHSTACK:
1223             {
1224                 dSP;
1225                 SWITCHSTACK(ARG0_AV, ARG1_AV);
1226                 PL_curstackinfo->si_stack = ARG1_AV;
1227             }
1228             break;
1229         case SAVEt_SET_SVFLAGS:
1230             SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
1231             SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
1232             break;
1233
1234             /* These are only saved in mathoms.c */
1235         case SAVEt_NSTAB:
1236             (void)sv_clear(ARG0_SV);
1237             break;
1238         case SAVEt_LONG:                        /* long reference */
1239             *(long*)ARG0_PTR = arg1.any_long;
1240             break;
1241         case SAVEt_IV:                          /* IV reference */
1242             *(IV*)ARG0_PTR = arg1.any_iv;
1243             break;
1244
1245         case SAVEt_I16:                         /* I16 reference */
1246             *(I16*)ARG0_PTR = (I16)(uv >> 8);
1247             break;
1248         case SAVEt_I8:                          /* I8 reference */
1249             *(I8*)ARG0_PTR = (I8)(uv >> 8);
1250             break;
1251         case SAVEt_DESTRUCTOR:
1252             (*arg1.any_dptr)(ARG0_PTR);
1253             break;
1254         case SAVEt_COMPILE_WARNINGS:
1255             if (!specialWARN(PL_compiling.cop_warnings))
1256                 PerlMemShared_free(PL_compiling.cop_warnings);
1257
1258             PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
1259             break;
1260         case SAVEt_PARSER:
1261             parser_free((yy_parser *) ARG0_PTR);
1262             break;
1263         case SAVEt_READONLY_OFF:
1264             SvREADONLY_off(ARG0_SV);
1265             break;
1266         default:
1267             Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
1268         }
1269     }
1270
1271     TAINT_set(was);
1272 }
1273
1274 void
1275 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1276 {
1277     PERL_ARGS_ASSERT_CX_DUMP;
1278
1279 #ifdef DEBUGGING
1280     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1281     if (CxTYPE(cx) != CXt_SUBST) {
1282         const char *gimme_text;
1283         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1284         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1285                       PTR2UV(cx->blk_oldcop));
1286         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1287         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1288         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1289                       PTR2UV(cx->blk_oldpm));
1290         switch (cx->blk_gimme) {
1291             case G_VOID:
1292                 gimme_text = "VOID";
1293                 break;
1294             case G_SCALAR:
1295                 gimme_text = "SCALAR";
1296                 break;
1297             case G_ARRAY:
1298                 gimme_text = "LIST";
1299                 break;
1300             default:
1301                 gimme_text = "UNKNOWN";
1302                 break;
1303         }
1304         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1305     }
1306     switch (CxTYPE(cx)) {
1307     case CXt_NULL:
1308     case CXt_BLOCK:
1309         break;
1310     case CXt_FORMAT:
1311         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1312                 PTR2UV(cx->blk_format.cv));
1313         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1314                 PTR2UV(cx->blk_format.gv));
1315         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1316                 PTR2UV(cx->blk_format.dfoutgv));
1317         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1318                       (int)CxHASARGS(cx));
1319         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1320                 PTR2UV(cx->blk_format.retop));
1321         break;
1322     case CXt_SUB:
1323         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1324                 PTR2UV(cx->blk_sub.cv));
1325         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1326                 (long)cx->blk_sub.olddepth);
1327         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1328                 (int)CxHASARGS(cx));
1329         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1330         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1331                 PTR2UV(cx->blk_sub.retop));
1332         break;
1333     case CXt_EVAL:
1334         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1335                 (long)CxOLD_IN_EVAL(cx));
1336         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1337                 PL_op_name[CxOLD_OP_TYPE(cx)],
1338                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1339         if (cx->blk_eval.old_namesv)
1340             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1341                           SvPVX_const(cx->blk_eval.old_namesv));
1342         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1343                 PTR2UV(cx->blk_eval.old_eval_root));
1344         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1345                 PTR2UV(cx->blk_eval.retop));
1346         break;
1347
1348     case CXt_LOOP_LAZYIV:
1349     case CXt_LOOP_LAZYSV:
1350     case CXt_LOOP_FOR:
1351     case CXt_LOOP_PLAIN:
1352         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1353         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1354                 (long)cx->blk_loop.resetsp);
1355         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1356                 PTR2UV(cx->blk_loop.my_op));
1357         /* XXX: not accurate for LAZYSV/IV */
1358         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1359                 PTR2UV(cx->blk_loop.state_u.ary.ary));
1360         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1361                 (long)cx->blk_loop.state_u.ary.ix);
1362         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1363                 PTR2UV(CxITERVAR(cx)));
1364         break;
1365
1366     case CXt_SUBST:
1367         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1368                 (long)cx->sb_iters);
1369         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1370                 (long)cx->sb_maxiters);
1371         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1372                 (long)cx->sb_rflags);
1373         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1374                 (long)CxONCE(cx));
1375         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1376                 cx->sb_orig);
1377         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1378                 PTR2UV(cx->sb_dstr));
1379         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1380                 PTR2UV(cx->sb_targ));
1381         PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1382                 PTR2UV(cx->sb_s));
1383         PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1384                 PTR2UV(cx->sb_m));
1385         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1386                 PTR2UV(cx->sb_strend));
1387         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1388                 PTR2UV(cx->sb_rxres));
1389         break;
1390     }
1391 #else
1392     PERL_UNUSED_CONTEXT;
1393     PERL_UNUSED_ARG(cx);
1394 #endif  /* DEBUGGING */
1395 }
1396
1397 /*
1398  * ex: set ts=8 sts=4 sw=4 et:
1399  */