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