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