scope.c

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