scope.c

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