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