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
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.
12 * For the fashion of Minas Tirith was such that it was built on seven
15 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"]
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
26 #define PERL_IN_SCOPE_C
31 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
34 SSize_t current = (p - PL_stack_base);
36 PERL_ARGS_ASSERT_STACK_GROW;
40 "panic: stack_grow() negative count (%" IVdf ")", (IV)n);
49 /* If the total might wrap, panic instead. This is really testing
50 * that (current + n + extra < SSize_t_MAX), but done in a way that
52 if (UNLIKELY( current > SSize_t_MAX - extra
53 || current + extra > SSize_t_MAX - n
55 /* diag_listed_as: Out of memory during %s extend */
56 Perl_croak(aTHX_ "Out of memory during stack extend");
58 av_extend(PL_curstack, current + n + extra);
60 PL_curstackinfo->si_stack_hwm = current + n + extra;
66 #ifndef STRESS_REALLOC
67 #define GROW(old) ((old) * 3 / 2)
69 #define GROW(old) ((old) + 1)
73 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
77 si->si_stack = newAV();
78 AvREAL_off(si->si_stack);
79 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
80 AvALLOC(si->si_stack)[0] = &PL_sv_undef;
81 AvFILLp(si->si_stack) = 0;
84 si->si_cxmax = cxitems - 1;
87 si->si_type = PERLSI_UNDEF;
88 Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
89 /* Without any kind of initialising CX_PUSHSUBST()
90 * in pp_subst() will read uninitialised heap. */
91 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
98 const IV old_max = cxstack_max;
99 const IV new_max = GROW(cxstack_max);
100 Renew(cxstack, new_max + 1, PERL_CONTEXT);
101 cxstack_max = new_max;
102 /* Without any kind of initialising deep enough recursion
103 * will end up reading uninitialised PERL_CONTEXTs. */
104 PoisonNew(cxstack + old_max + 1, new_max - old_max, PERL_CONTEXT);
105 return cxstack_ix + 1;
109 =for apidoc_section $callback
110 =for apidoc push_scope
112 Implements L<perlapi/C<ENTER>>
118 Perl_push_scope(pTHX)
120 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) {
121 const IV new_max = GROW(PL_scopestack_max);
122 Renew(PL_scopestack, new_max, I32);
124 Renew(PL_scopestack_name, new_max, const char*);
126 PL_scopestack_max = new_max;
129 PL_scopestack_name[PL_scopestack_ix] = "unknown";
131 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
136 =for apidoc_section $callback
137 =for apidoc pop_scope
139 Implements L<perlapi/C<LEAVE>>
147 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
148 LEAVE_SCOPE(oldsave);
152 Perl_markstack_grow(pTHX)
154 const I32 oldmax = PL_markstack_max - PL_markstack;
155 const I32 newmax = GROW(oldmax);
157 Renew(PL_markstack, newmax, I32);
158 PL_markstack_max = PL_markstack + newmax;
159 PL_markstack_ptr = PL_markstack + oldmax;
160 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
161 "MARK grow %p %" IVdf " by %" IVdf "\n",
162 PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax)));
163 return PL_markstack_ptr;
167 Perl_savestack_grow(pTHX)
170 #ifdef STRESS_REALLOC
171 new_max = PL_savestack_max + SS_MAXPUSH;
173 new_max = GROW(PL_savestack_max);
175 /* Note that we allocate SS_MAXPUSH slots higher than ss_max
176 * so that SS_ADD_END(), SSGROW() etc can do a simper check */
177 Renew(PL_savestack, new_max + SS_MAXPUSH, ANY);
178 PL_savestack_max = new_max;
182 Perl_savestack_grow_cnt(pTHX_ I32 need)
184 const IV new_max = PL_savestack_ix + need;
185 /* Note that we allocate SS_MAXPUSH slots higher than ss_max
186 * so that SS_ADD_END(), SSGROW() etc can do a simper check */
187 Renew(PL_savestack, new_max + SS_MAXPUSH, ANY);
188 PL_savestack_max = new_max;
193 /* The original function was called Perl_tmps_grow and was removed from public
194 API, Perl_tmps_grow_p is the replacement and it used in public macros but
197 Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by,
198 where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max
199 Upon return, PL_tmps_stack[ix] will be a valid address. For machine code
200 optimization and register usage reasons, the proposed ix passed into
201 tmps_grow is returned to the caller which the caller can then use to write
202 an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in
203 pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of
204 tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller
205 must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is
206 appropriate. The assignment to PL_temps_ix can happen before or after
207 tmps_grow call since tmps_grow doesn't look at PL_tmps_ix.
211 Perl_tmps_grow_p(pTHX_ SSize_t ix)
213 SSize_t extend_to = ix;
214 #ifndef STRESS_REALLOC
215 if (ix - PL_tmps_max < 128)
216 extend_to += (PL_tmps_max < 512) ? 128 : 512;
218 Renew(PL_tmps_stack, extend_to + 1, SV*);
219 PL_tmps_max = extend_to + 1;
227 /* XXX should tmps_floor live in cxstack? */
228 const SSize_t myfloor = PL_tmps_floor;
229 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
230 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
232 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
236 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
242 =for apidoc save_scalar_at
244 A helper function for localizing the SV referenced by C<*sptr>.
246 If C<SAVEf_KEEPOLDELEM> is set in in C<flags>, the function returns the input
249 Otherwise it replaces C<*sptr> with a new C<undef> scalar, and returns that.
250 The new scalar will have the old one's magic (if any) copied to it.
251 If there is such magic, and C<SAVEf_SETMAGIC> is set in in C<flags>, 'set'
252 magic will be processed on the new scalar. If unset, 'set' magic will be
253 skipped. The latter typically means that assignment will soon follow (I<e.g.>,
254 S<C<'local $x = $y'>>), and that will handle the magic.
256 =for apidoc Amnh ||SAVEf_KEEPOLDELEM
257 =for apidoc Amnh ||SAVEf_SETMAGIC
263 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
268 PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
271 if (flags & SAVEf_KEEPOLDELEM)
274 sv = (*sptr = newSV_type(SVt_NULL));
275 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv))
276 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
283 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
293 Perl_save_scalar(pTHX_ GV *gv)
295 SV ** const sptr = &GvSVn(gv);
297 PERL_ARGS_ASSERT_SAVE_SCALAR;
299 if (UNLIKELY(SvGMAGICAL(*sptr))) {
304 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
305 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
309 =for apidoc save_generic_svref
311 Implements C<SAVEGENERICSV>.
313 Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
314 restore a global SV to its prior contents, freeing new value.
320 Perl_save_generic_svref(pTHX_ SV **sptr)
322 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
324 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
328 =for apidoc_section $callback
329 =for apidoc save_generic_pvref
331 Implements C<SAVEGENERICPV>.
333 Like save_pptr(), but also Safefree()s the new value if it is different
334 from the old one. Can be used to restore a global char* to its prior
335 contents, freeing new value.
341 Perl_save_generic_pvref(pTHX_ char **str)
343 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
345 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
349 =for apidoc_section $callback
350 =for apidoc save_shared_pvref
352 Implements C<SAVESHAREDPV>.
354 Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
355 Can be used to restore a shared global char* to its prior
356 contents, freeing new value.
362 Perl_save_shared_pvref(pTHX_ char **str)
364 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
366 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
371 =for apidoc_section $callback
372 =for apidoc save_set_svflags
374 Implements C<SAVESETSVFLAGS>.
376 Set the SvFLAGS specified by mask to the values in val
382 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
386 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
391 SS_ADD_UV(SAVEt_SET_SVFLAGS);
397 =for apidoc_section $GV
401 Saves the current GP of gv on the save stack to be restored on scope exit.
403 If C<empty> is true, replace the GP with a new GP.
405 If C<empty> is false, mark C<gv> with C<GVf_INTRO> so the next reference
406 assigned is localized, which is how S<C< local *foo = $someref; >> works.
412 Perl_save_gp(pTHX_ GV *gv, I32 empty)
414 PERL_ARGS_ASSERT_SAVE_GP;
416 /* XXX For now, we just upgrade any coderef in the stash to a full GV
417 during localisation. Maybe at some point we could make localis-
418 ation work without needing the upgrade. (In which case our
419 callers should probably call a different function, not save_gp.)
422 assert(isGV_or_RVCV(gv));
423 (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */
427 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
430 GP *gp = Perl_newGP(aTHX_ gv);
431 HV * const stash = GvSTASH(gv);
432 bool isa_changed = 0;
434 if (stash && HvENAME(stash)) {
435 if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
438 /* taking a method out of circulation ("local")*/
439 mro_method_changed_in(stash);
441 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
443 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
446 if (isa_changed) mro_isa_changed_in(stash);
455 Perl_save_ary(pTHX_ GV *gv)
457 AV * const oav = GvAVn(gv);
460 PERL_ARGS_ASSERT_SAVE_ARY;
462 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav)))
464 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
468 if (UNLIKELY(SvMAGIC(oav)))
469 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
474 Perl_save_hash(pTHX_ GV *gv)
478 PERL_ARGS_ASSERT_SAVE_HASH;
481 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
486 if (UNLIKELY(SvMAGIC(ohv)))
487 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
492 Perl_save_item(pTHX_ SV *item)
494 SV * const sv = newSVsv(item);
496 PERL_ARGS_ASSERT_SAVE_ITEM;
498 save_pushptrptr(item, /* remember the pointer */
499 sv, /* remember the value */
504 Perl_save_bool(pTHX_ bool *boolp)
508 PERL_ARGS_ASSERT_SAVE_BOOL;
511 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
516 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
527 Perl_save_int(pTHX_ int *intp)
530 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
534 PERL_ARGS_ASSERT_SAVE_INT;
536 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) {
547 Perl_save_I8(pTHX_ I8 *bytep)
551 PERL_ARGS_ASSERT_SAVE_I8;
554 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
559 Perl_save_I16(pTHX_ I16 *intp)
563 PERL_ARGS_ASSERT_SAVE_I16;
566 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
571 Perl_save_I32(pTHX_ I32 *intp)
574 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
578 PERL_ARGS_ASSERT_SAVE_I32;
580 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
591 Perl_save_strlen(pTHX_ STRLEN *ptr)
594 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_STRLEN_SMALL);
598 PERL_ARGS_ASSERT_SAVE_STRLEN;
600 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
612 Perl_save_iv(pTHX_ IV *ivp)
614 PERL_ARGS_ASSERT_SAVE_IV;
622 /* Cannot use save_sptr() to store a char* since the SV** cast will
623 * force word-alignment and we'll miss the pointer.
626 Perl_save_pptr(pTHX_ char **pptr)
628 PERL_ARGS_ASSERT_SAVE_PPTR;
630 save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
634 =for apidoc_section $callback
635 =for apidoc save_vptr
637 Implements C<SAVEVPTR>.
643 Perl_save_vptr(pTHX_ void *ptr)
645 PERL_ARGS_ASSERT_SAVE_VPTR;
647 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
651 Perl_save_sptr(pTHX_ SV **sptr)
653 PERL_ARGS_ASSERT_SAVE_SPTR;
655 save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
659 =for apidoc_section $callback
660 =for apidoc save_padsv_and_mortalize
662 Implements C<SAVEPADSVANDMORTALIZE>.
668 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
672 ASSERT_CURPAD_ACTIVE("save_padsv");
673 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
674 SS_ADD_PTR(PL_comppad);
676 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
681 Perl_save_hptr(pTHX_ HV **hptr)
683 PERL_ARGS_ASSERT_SAVE_HPTR;
685 save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
689 Perl_save_aptr(pTHX_ AV **aptr)
691 PERL_ARGS_ASSERT_SAVE_APTR;
693 save_pushptrptr(*aptr, aptr, SAVEt_APTR);
697 =for apidoc_section $callback
698 =for apidoc save_pushptr
700 The refcnt of object C<ptr> will be decremented at the end of the current
701 I<pseudo-block>. C<type> gives the type of C<ptr>, expressed as one of the
702 constants in F<scope.h> whose name begins with C<SAVEt_>.
704 This is the underlying implementation of several macros, like
711 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
720 Perl_save_clearsv(pTHX_ SV **svp)
722 const UV offset = svp - PL_curpad;
723 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
725 PERL_ARGS_ASSERT_SAVE_CLEARSV;
727 ASSERT_CURPAD_ACTIVE("save_clearsv");
728 SvPADSTALE_off(*svp); /* mark lexical as active */
729 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) {
730 Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)",
731 offset, svp, PL_curpad);
736 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
742 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
744 PERL_ARGS_ASSERT_SAVE_DELETE;
746 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
750 =for apidoc_section $callback
751 =for apidoc save_hdelete
753 Implements C<SAVEHDELETE>.
759 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
765 PERL_ARGS_ASSERT_SAVE_HDELETE;
767 key = SvPV_const(keysv, len);
768 klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
769 SvREFCNT_inc_simple_void_NN(hv);
770 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
774 =for apidoc_section $callback
775 =for apidoc save_adelete
777 Implements C<SAVEADELETE>.
783 Perl_save_adelete(pTHX_ AV *av, SSize_t key)
787 PERL_ARGS_ASSERT_SAVE_ADELETE;
789 SvREFCNT_inc_void(av);
792 SS_ADD_IV(SAVEt_ADELETE);
797 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
800 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
804 SS_ADD_UV(SAVEt_DESTRUCTOR);
809 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
815 SS_ADD_UV(SAVEt_DESTRUCTOR_X);
820 =for apidoc_section $callback
821 =for apidoc save_hints
823 Implements C<SAVEHINTS>.
829 Perl_save_hints(pTHX)
831 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
832 if (PL_hints & HINT_LOCALIZE_HH) {
833 HV *oldhh = GvHV(PL_hintgv);
836 SS_ADD_INT(PL_hints);
837 SS_ADD_PTR(save_cophh);
839 SS_ADD_UV(SAVEt_HINTS_HH | (PL_prevailing_version << 8));
842 GvHV(PL_hintgv) = NULL; /* in case copying dies */
843 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
846 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS | (PL_prevailing_version << 8));
851 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
863 =for apidoc_section $callback
864 =for apidoc save_aelem
865 =for apidoc_item save_aelem_flags
867 These each arrange for the value of the array element C<av[idx]> to be restored
868 at the end of the enclosing I<pseudo-block>.
870 In C<save_aelem>, the SV at C**sptr> will be replaced by a new C<undef>
871 scalar. That scalar will inherit any magic from the original C<**sptr>,
872 and any 'set' magic will be processed.
874 In C<save_aelem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
875 the function to forgo all that: the scalar at C<**sptr> is untouched.
876 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
877 new C<undef> scalar. That scalar will inherit any magic from the original
878 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
879 is set in in C<flags>.
885 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr,
891 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
894 SS_ADD_PTR(SvREFCNT_inc_simple(av));
896 SS_ADD_PTR(SvREFCNT_inc(*sptr));
897 SS_ADD_UV(SAVEt_AELEM);
899 /* The array needs to hold a reference count on its new element, so it
901 if (UNLIKELY(!AvREAL(av) && AvREIFY(av)))
903 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
904 if (flags & SAVEf_KEEPOLDELEM)
907 /* If we're localizing a tied array element, this new sv
908 * won't actually be stored in the array - so it won't get
909 * reaped when the localize ends. Ensure it gets reaped by
910 * mortifying it instead. DAPM */
911 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied)))
916 =for apidoc_section $callback
917 =for apidoc save_helem
918 =for apidoc_item save_helem_flags
920 These each arrange for the value of the hash element (in Perlish terms)
921 C<$hv{key}]> to be restored at the end of the enclosing I<pseudo-block>.
923 In C<save_helem>, the SV at C**sptr> will be replaced by a new C<undef>
924 scalar. That scalar will inherit any magic from the original C<**sptr>,
925 and any 'set' magic will be processed.
927 In C<save_helem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
928 the function to forgo all that: the scalar at C<**sptr> is untouched.
929 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
930 new C<undef> scalar. That scalar will inherit any magic from the original
931 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
932 is set in in C<flags>.
938 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
942 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
947 SS_ADD_PTR(SvREFCNT_inc_simple(hv));
948 SS_ADD_PTR(newSVsv(key));
949 SS_ADD_PTR(SvREFCNT_inc(*sptr));
950 SS_ADD_UV(SAVEt_HELEM);
953 save_scalar_at(sptr, flags);
954 if (flags & SAVEf_KEEPOLDELEM)
957 /* If we're localizing a tied hash element, this new sv
958 * won't actually be stored in the hash - so it won't get
959 * reaped when the localize ends. Ensure it gets reaped by
960 * mortifying it instead. DAPM */
961 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)))
966 Perl_save_svref(pTHX_ SV **sptr)
968 PERL_ARGS_ASSERT_SAVE_SVREF;
971 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
972 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
980 SS_ADD_IV(PL_tmps_floor);
981 PL_tmps_floor = PL_tmps_ix;
982 SS_ADD_UV(SAVEt_TMPSFLOOR);
987 =for apidoc_section $stack
988 =for apidoc save_alloc
990 Implements L<perlapi/C<SSNEW>> and kin, which should be used instead of this
997 Perl_save_alloc(pTHX_ I32 size, I32 pad)
999 const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
1000 - (char*)PL_savestack);
1001 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
1002 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
1004 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems))
1006 "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")",
1007 elems, (IV)size, (IV)pad);
1011 PL_savestack_ix += elems;
1012 SSPUSHUV(SAVEt_ALLOC | elems_shifted);
1017 static const U8 arg_counts[] = {
1018 0, /* SAVEt_ALLOC */
1019 0, /* SAVEt_CLEARPADRANGE */
1020 0, /* SAVEt_CLEARSV */
1021 0, /* SAVEt_REGCONTEXT */
1022 1, /* SAVEt_TMPSFLOOR */
1024 1, /* SAVEt_COMPILE_WARNINGS */
1025 1, /* SAVEt_COMPPAD */
1026 1, /* SAVEt_FREECOPHH */
1027 1, /* SAVEt_FREEOP */
1028 1, /* SAVEt_FREEPV */
1029 1, /* SAVEt_FREESV */
1031 1, /* SAVEt_I32_SMALL */
1033 1, /* SAVEt_INT_SMALL */
1034 1, /* SAVEt_MORTALIZESV */
1035 1, /* SAVEt_NSTAB */
1037 1, /* SAVEt_PARSER */
1038 1, /* SAVEt_STACK_POS */
1039 1, /* SAVEt_READONLY_OFF */
1040 1, /* SAVEt_FREEPADNAME */
1041 1, /* SAVEt_STRLEN_SMALL */
1043 2, /* SAVEt_DESTRUCTOR */
1044 2, /* SAVEt_DESTRUCTOR_X */
1045 2, /* SAVEt_GENERIC_PVREF */
1046 2, /* SAVEt_GENERIC_SVREF */
1049 2, /* SAVEt_HINTS */
1058 2, /* SAVEt_SAVESWITCHSTACK */
1059 2, /* SAVEt_SHARED_PVREF */
1061 2, /* SAVEt_STRLEN */
1063 2, /* SAVEt_SVREF */
1065 2, /* SAVEt_ADELETE */
1067 3, /* SAVEt_HELEM */
1068 3, /* SAVEt_PADSV_AND_MORTALIZE*/
1069 3, /* SAVEt_SET_SVFLAGS */
1070 3, /* SAVEt_GVSLOT */
1071 3, /* SAVEt_AELEM */
1072 3, /* SAVEt_DELETE */
1073 3 /* SAVEt_HINTS_HH */
1078 =for apidoc_section $callback
1079 =for apidoc leave_scope
1081 Implements C<LEAVE_SCOPE> which you should use instead.
1087 Perl_leave_scope(pTHX_ I32 base)
1089 /* Localise the effects of the TAINT_NOT inside the loop. */
1090 bool was = TAINT_get;
1092 if (UNLIKELY(base < -1))
1093 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
1094 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
1095 (long)PL_savestack_ix, (long)base));
1096 while (PL_savestack_ix > base) {
1099 ANY *ap; /* arg pointer */
1100 ANY a0, a1, a2; /* up to 3 args */
1106 I32 ix = PL_savestack_ix - 1;
1108 ap = &PL_savestack[ix];
1110 type = (U8)uv & SAVE_MASK;
1111 argcount = arg_counts[type];
1112 PL_savestack_ix = ix - argcount;
1117 case SAVEt_ITEM: /* normal string */
1118 a0 = ap[0]; a1 = ap[1];
1119 sv_replace(a0.any_sv, a1.any_sv);
1120 if (UNLIKELY(SvSMAGICAL(a0.any_sv))) {
1127 /* This would be a mathom, but Perl_save_svref() calls a static
1128 function, S_save_scalar_at(), so has to stay in this file. */
1129 case SAVEt_SVREF: /* scalar reference */
1130 a0 = ap[0]; a1 = ap[1];
1131 a2.any_svp = a0.any_svp;
1132 a0.any_sv = NULL; /* what to refcnt_dec */
1135 case SAVEt_SV: /* scalar reference */
1136 a0 = ap[0]; a1 = ap[1];
1137 a2.any_svp = &GvSV(a0.any_gv);
1140 /* do *a2.any_svp = a1 and free a0 */
1141 SV * const sv = *a2.any_svp;
1142 *a2.any_svp = a1.any_sv;
1144 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1145 /* mg_set could die, skipping the freeing of a0 and
1146 * a1; Ensure that they're always freed in that case */
1148 SS_ADD_PTR(a1.any_sv);
1149 SS_ADD_UV(SAVEt_FREESV);
1150 SS_ADD_PTR(a0.any_sv);
1151 SS_ADD_UV(SAVEt_FREESV);
1158 SvREFCNT_dec_NN(a1.any_sv);
1159 SvREFCNT_dec(a0.any_sv);
1163 case SAVEt_GENERIC_PVREF: /* generic pv */
1164 a0 = ap[0]; a1 = ap[1];
1165 if (*a1.any_pvp != a0.any_pv) {
1166 Safefree(*a1.any_pvp);
1167 *a1.any_pvp = a0.any_pv;
1171 case SAVEt_SHARED_PVREF: /* shared pv */
1172 a0 = ap[0]; a1 = ap[1];
1173 if (*a0.any_pvp != a1.any_pv) {
1174 PerlMemShared_free(*a0.any_pvp);
1175 *a0.any_pvp = a1.any_pv;
1179 case SAVEt_GVSV: /* scalar slot in GV */
1180 a0 = ap[0]; a1 = ap[1];
1181 a0.any_svp = &GvSV(a0.any_gv);
1184 case SAVEt_GENERIC_SVREF: /* generic sv */
1185 a0 = ap[0]; a1 = ap[1];
1188 /* do *a0.any_svp = a1 */
1189 SV * const sv = *a0.any_svp;
1190 *a0.any_svp = a1.any_sv;
1192 SvREFCNT_dec(a1.any_sv);
1196 case SAVEt_GVSLOT: /* any slot in GV */
1199 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1200 hv = GvSTASH(a0.any_gv);
1201 if (hv && HvENAME(hv) && (
1202 (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV)
1203 || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV)
1206 if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv)
1207 || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp)
1208 || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */
1209 PL_sub_generation++;
1210 else mro_method_changed_in(hv);
1212 a0.any_svp = a1.any_svp;
1213 a1.any_sv = a2.any_sv;
1217 case SAVEt_AV: /* array reference */
1218 a0 = ap[0]; a1 = ap[1];
1219 SvREFCNT_dec(GvAV(a0.any_gv));
1220 GvAV(a0.any_gv) = a1.any_av;
1222 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1223 /* mg_set might die, so make sure a0 isn't leaked */
1225 SS_ADD_PTR(a0.any_sv);
1226 SS_ADD_UV(SAVEt_FREESV);
1233 SvREFCNT_dec_NN(a0.any_sv);
1236 case SAVEt_HV: /* hash reference */
1237 a0 = ap[0]; a1 = ap[1];
1238 SvREFCNT_dec(GvHV(a0.any_gv));
1239 GvHV(a0.any_gv) = a1.any_hv;
1242 case SAVEt_INT_SMALL:
1244 *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
1247 case SAVEt_INT: /* int reference */
1248 a0 = ap[0]; a1 = ap[1];
1249 *(int*)a1.any_ptr = (int)a0.any_i32;
1252 case SAVEt_STRLEN_SMALL:
1254 *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT);
1257 case SAVEt_STRLEN: /* STRLEN/size_t ref */
1258 a0 = ap[0]; a1 = ap[1];
1259 *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv;
1262 case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */
1264 PL_tmps_floor = (SSize_t)a0.any_iv;
1267 case SAVEt_BOOL: /* bool reference */
1269 *(bool*)a0.any_ptr = cBOOL(uv >> 8);
1270 #ifdef NO_TAINT_SUPPORT
1271 PERL_UNUSED_VAR(was);
1273 if (UNLIKELY(a0.any_ptr == &(PL_tainted))) {
1274 /* If we don't update <was>, to reflect what was saved on the
1275 * stack for PL_tainted, then we will overwrite this attempt to
1276 * restore it when we exit this routine. Note that this won't
1277 * work if this value was saved in a wider-than necessary type,
1279 was = *(bool*)a0.any_ptr;
1284 case SAVEt_I32_SMALL:
1286 *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
1289 case SAVEt_I32: /* I32 reference */
1290 a0 = ap[0]; a1 = ap[1];
1291 #ifdef PERL_DEBUG_READONLY_OPS
1292 if (*(I32*)a1.any_ptr != a0.any_i32)
1294 *(I32*)a1.any_ptr = a0.any_i32;
1297 case SAVEt_SPTR: /* SV* reference */
1298 case SAVEt_VPTR: /* random* reference */
1299 case SAVEt_PPTR: /* char* reference */
1300 case SAVEt_HPTR: /* HV* reference */
1301 case SAVEt_APTR: /* AV* reference */
1302 a0 = ap[0]; a1 = ap[1];
1303 *a1.any_svp= a0.any_sv;
1306 case SAVEt_GP: /* scalar reference */
1311 a0 = ap[0]; a1 = ap[1];
1312 /* possibly taking a method out of circulation */
1313 had_method = cBOOL(GvCVu(a0.any_gv));
1315 GvGP_set(a0.any_gv, (GP*)a1.any_ptr);
1316 if ((hv=GvSTASH(a0.any_gv)) && HvENAME_get(hv)) {
1317 if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA"))
1318 mro_isa_changed_in(hv);
1319 else if (had_method || GvCVu(a0.any_gv))
1320 /* putting a method back into circulation ("local")*/
1321 gv_method_changed(a0.any_gv);
1323 SvREFCNT_dec_NN(a0.any_gv);
1329 SvREFCNT_dec(a0.any_sv);
1332 case SAVEt_FREEPADNAME:
1334 PadnameREFCNT_dec((PADNAME *)a0.any_ptr);
1337 case SAVEt_FREECOPHH:
1339 cophh_free((COPHH *)a0.any_ptr);
1342 case SAVEt_MORTALIZESV:
1344 sv_2mortal(a0.any_sv);
1349 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
1355 Safefree(a0.any_ptr);
1358 case SAVEt_CLEARPADRANGE:
1362 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1363 svp = &PL_curpad[uv >>
1364 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1367 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1370 for (; i; i--, svp--) {
1373 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1374 "Pad 0x%" UVxf "[0x%" UVxf "] clearsv: %ld sv=0x%" UVxf "<%" IVdf "> %s\n",
1375 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1376 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1377 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1380 /* Can clear pad variable in place? */
1381 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
1383 /* these flags are the union of all the relevant flags
1384 * in the individual conditions within */
1385 if (UNLIKELY(SvFLAGS(sv) & (
1386 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
1387 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
1391 /* if a my variable that was made readonly is
1392 * going out of scope, we want to remove the
1393 * readonlyness so that it can go out of scope
1399 if (SvTYPE(sv) == SVt_PVHV && HvHasAUX(sv))
1400 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1404 if (SvMAGICAL(sv)) {
1405 /* note that backrefs (either in HvAUX or magic)
1406 * must be removed before other magic */
1407 sv_unmagic(sv, PERL_MAGIC_backref);
1408 if (SvTYPE(sv) != SVt_PVCV)
1411 if (SvTHINKFIRST(sv))
1412 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1416 switch (SvTYPE(sv)) {
1420 av_clear(MUTABLE_AV(sv));
1423 hv_clear(MUTABLE_HV(sv));
1427 HEK *hek = CvGvNAME_HEK(sv);
1429 (void)share_hek_hek(hek);
1431 CvNAME_HEK_set(sv, hek);
1436 /* This looks odd, but these two macros are for use in
1437 expressions and finish with a trailing comma, so
1438 adding a ; after them would be wrong. */
1441 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
1445 SvPADSTALE_on(sv); /* mark as no longer live */
1447 else { /* Someone has a claim on this, so abandon it. */
1448 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
1449 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
1450 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
1453 HEK * const hek = CvGvNAME_HEK(sv);
1456 *svp = newSV_type(SVt_PVCV);
1459 CvNAME_HEK_set(*svp,
1460 share_hek_hek(hek));
1464 default: *svp = newSV_type(SVt_NULL); break;
1466 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1467 /* preserve pad nature, but also mark as not live
1468 * for any closure capturing */
1469 SvFLAGS(*svp) |= SVs_PADSTALE;
1476 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1477 /* hv_delete could die, so free the key and SvREFCNT_dec the
1478 * hv by pushing new save actions
1480 /* ap[0] is the key */
1481 ap[1].any_uv = SAVEt_FREEPV; /* was len */
1482 /* ap[2] is the hv */
1483 ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */
1484 PL_savestack_ix += 4;
1485 (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD);
1489 a0 = ap[0]; a1 = ap[1];
1490 /* av_delete could die, so SvREFCNT_dec the av by pushing a
1493 ap[0].any_av = a1.any_av;
1494 ap[1].any_uv = SAVEt_FREESV;
1495 PL_savestack_ix += 2;
1496 (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD);
1499 case SAVEt_DESTRUCTOR_X:
1500 a0 = ap[0]; a1 = ap[1];
1501 (*a0.any_dxptr)(aTHX_ a1.any_ptr);
1504 case SAVEt_REGCONTEXT:
1505 /* regexp must have croaked */
1507 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1510 case SAVEt_STACK_POS: /* Position on Perl stack */
1512 PL_stack_sp = PL_stack_base + a0.any_i32;
1515 case SAVEt_AELEM: /* array element */
1518 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1519 svp = av_fetch(a0.any_av, a1.any_iv, 1);
1520 if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */
1521 SvREFCNT_dec(a2.any_sv);
1523 SV * const sv = *svp;
1524 if (LIKELY(sv && sv != &PL_sv_undef)) {
1525 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied)))
1526 SvREFCNT_inc_void_NN(sv);
1527 a1.any_sv = a2.any_sv;
1532 SvREFCNT_dec(a0.any_av);
1533 SvREFCNT_dec(a2.any_sv);
1537 case SAVEt_HELEM: /* hash element */
1541 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1542 he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0);
1543 SvREFCNT_dec(a1.any_sv);
1545 const SV * const oval = HeVAL(he);
1546 if (LIKELY(oval && oval != &PL_sv_undef)) {
1547 SV **svp = &HeVAL(he);
1548 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied)))
1549 SvREFCNT_inc_void(*svp);
1550 a1.any_sv = a2.any_sv;
1555 SvREFCNT_dec(a0.any_hv);
1556 SvREFCNT_dec(a2.any_sv);
1562 PL_op = (OP*)a0.any_ptr;
1565 case SAVEt_HINTS_HH:
1569 a0 = ap[0]; a1 = ap[1];
1570 if ((PL_hints & HINT_LOCALIZE_HH)) {
1571 while (GvHV(PL_hintgv)) {
1572 HV *hv = GvHV(PL_hintgv);
1573 GvHV(PL_hintgv) = NULL;
1574 SvREFCNT_dec(MUTABLE_SV(hv));
1577 cophh_free(CopHINTHASH_get(&PL_compiling));
1578 CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr);
1579 *(I32*)&PL_hints = a0.any_i32;
1580 PL_prevailing_version = (U16)(uv >> 8);
1581 if (type == SAVEt_HINTS_HH) {
1582 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1583 GvHV(PL_hintgv) = MUTABLE_HV(a2.any_ptr);
1585 if (!GvHV(PL_hintgv)) {
1586 /* Need to add a new one manually, else rv2hv can
1587 add one via GvHVn and it won't have the magic set. */
1588 HV *const hv = newHV();
1589 hv_magic(hv, NULL, PERL_MAGIC_hints);
1590 GvHV(PL_hintgv) = hv;
1592 assert(GvHV(PL_hintgv));
1597 PL_comppad = (PAD*)a0.any_ptr;
1598 if (LIKELY(PL_comppad))
1599 PL_curpad = AvARRAY(PL_comppad);
1604 case SAVEt_PADSV_AND_MORTALIZE:
1608 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1609 assert (a1.any_ptr);
1610 svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv;
1611 /* This mortalizing used to be done by CX_POOPLOOP() via
1612 itersave. But as we have all the information here, we
1613 can do it here, save even having to have itersave in
1621 case SAVEt_SAVESWITCHSTACK:
1625 a0 = ap[0]; a1 = ap[1];
1626 SWITCHSTACK(a1.any_av, a0.any_av);
1627 PL_curstackinfo->si_stack = a0.any_av;
1631 case SAVEt_SET_SVFLAGS:
1632 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1633 SvFLAGS(a0.any_sv) &= ~(a1.any_u32);
1634 SvFLAGS(a0.any_sv) |= a2.any_u32;
1637 /* These are only saved in mathoms.c */
1640 (void)sv_clear(a0.any_sv);
1643 case SAVEt_LONG: /* long reference */
1644 a0 = ap[0]; a1 = ap[1];
1645 *(long*)a1.any_ptr = a0.any_long;
1648 case SAVEt_IV: /* IV reference */
1649 a0 = ap[0]; a1 = ap[1];
1650 *(IV*)a1.any_ptr = a0.any_iv;
1653 case SAVEt_I16: /* I16 reference */
1655 *(I16*)a0.any_ptr = (I16)(uv >> 8);
1658 case SAVEt_I8: /* I8 reference */
1660 *(I8*)a0.any_ptr = (I8)(uv >> 8);
1663 case SAVEt_DESTRUCTOR:
1664 a0 = ap[0]; a1 = ap[1];
1665 (*a0.any_dptr)(a1.any_ptr);
1668 case SAVEt_COMPILE_WARNINGS:
1670 free_and_set_cop_warnings(&PL_compiling, (STRLEN*) a0.any_ptr);
1675 parser_free((yy_parser *)a0.any_ptr);
1678 case SAVEt_READONLY_OFF:
1680 SvREADONLY_off(a0.any_sv);
1684 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u",
1685 (U8)uv & SAVE_MASK);
1693 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1695 PERL_ARGS_ASSERT_CX_DUMP;
1698 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1699 if (CxTYPE(cx) != CXt_SUBST) {
1700 const char *gimme_text;
1701 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1702 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n",
1703 PTR2UV(cx->blk_oldcop));
1704 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1705 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1706 PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix);
1707 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n",
1708 PTR2UV(cx->blk_oldpm));
1709 switch (cx->blk_gimme) {
1711 gimme_text = "VOID";
1714 gimme_text = "SCALAR";
1717 gimme_text = "LIST";
1720 gimme_text = "UNKNOWN";
1723 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1725 switch (CxTYPE(cx)) {
1731 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n",
1732 PTR2UV(cx->blk_format.cv));
1733 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n",
1734 PTR2UV(cx->blk_format.gv));
1735 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n",
1736 PTR2UV(cx->blk_format.dfoutgv));
1737 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1738 (int)CxHASARGS(cx));
1739 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n",
1740 PTR2UV(cx->blk_format.retop));
1743 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n",
1744 PTR2UV(cx->blk_sub.cv));
1745 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1746 (long)cx->blk_sub.olddepth);
1747 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1748 (int)CxHASARGS(cx));
1749 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1750 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n",
1751 PTR2UV(cx->blk_sub.retop));
1754 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1755 (long)CxOLD_IN_EVAL(cx));
1756 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1757 PL_op_name[CxOLD_OP_TYPE(cx)],
1758 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1759 if (cx->blk_eval.old_namesv)
1760 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1761 SvPVX_const(cx->blk_eval.old_namesv));
1762 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n",
1763 PTR2UV(cx->blk_eval.old_eval_root));
1764 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n",
1765 PTR2UV(cx->blk_eval.retop));
1768 case CXt_LOOP_PLAIN:
1769 case CXt_LOOP_LAZYIV:
1770 case CXt_LOOP_LAZYSV:
1773 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1774 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n",
1775 PTR2UV(cx->blk_loop.my_op));
1776 if (CxTYPE(cx) != CXt_LOOP_PLAIN) {
1777 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n",
1778 PTR2UV(CxITERVAR(cx)));
1779 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n",
1780 PTR2UV(cx->blk_loop.itersave));
1782 if (CxTYPE(cx) == CXt_LOOP_ARY) {
1783 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n",
1784 PTR2UV(cx->blk_loop.state_u.ary.ary));
1785 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1786 (long)cx->blk_loop.state_u.ary.ix);
1791 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1792 (long)cx->sb_iters);
1793 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1794 (long)cx->sb_maxiters);
1795 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1796 (long)cx->sb_rflags);
1797 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1799 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1801 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n",
1802 PTR2UV(cx->sb_dstr));
1803 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n",
1804 PTR2UV(cx->sb_targ));
1805 PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n",
1807 PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n",
1809 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n",
1810 PTR2UV(cx->sb_strend));
1811 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n",
1812 PTR2UV(cx->sb_rxres));
1816 PERL_UNUSED_CONTEXT;
1817 PERL_UNUSED_ARG(cx);
1818 #endif /* DEBUGGING */
1822 * ex: set ts=8 sts=4 sw=4 et: