X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/459defa14829d1e98582a2fcd871ef3425e1fe38..4596056478d3ae4ae183d2821eb95156aff83924:/scope.c

diff --git a/scope.c b/scope.c
index de7d205..046b338 100644
--- a/scope.c
+++ b/scope.c
@@ -77,7 +77,7 @@ Perl_cxinc(pTHX)
     dVAR;
     const IV old_max = cxstack_max;
     cxstack_max = GROW(cxstack_max);
-    Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);	/* XXX should fix CXINC macro */
+    Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);
     /* Without any kind of initialising deep enough recursion
      * will end up reading uninitialised PERL_CONTEXTs. */
     PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
@@ -202,7 +202,7 @@ Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
     SSCHECK(3);
     SSPUSHPTR(ptr1);
     SSPUSHPTR(ptr2);
-    SSPUSHINT(type);
+    SSPUSHUV(type);
 }
 
 SV *
@@ -271,7 +271,7 @@ Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
     SSPUSHPTR(sv);
     SSPUSHINT(mask);
     SSPUSHINT(val);
-    SSPUSHINT(SAVEt_SET_SVFLAGS);
+    SSPUSHUV(SAVEt_SET_SVFLAGS);
 }
 
 void
@@ -281,7 +281,15 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 
     PERL_ARGS_ASSERT_SAVE_GP;
 
-    save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
+    SSCHECK(4);
+    SSPUSHINT(SvFAKE(gv));
+    SSPUSHPTR(GvGP(gv));
+    SSPUSHPTR(SvREFCNT_inc(gv));
+    SSPUSHUV(SAVEt_GP);
+
+    /* Don't let the localized GV coerce into non-glob, otherwise we would
+     * not be able to restore GP upon leave from context if that happened */
+    SvFAKE_off(gv);
 
     if (empty) {
 	GP *gp = Perl_newGP(aTHX_ gv);
@@ -365,10 +373,9 @@ Perl_save_bool(pTHX_ bool *boolp)
 
     PERL_ARGS_ASSERT_SAVE_BOOL;
 
-    SSCHECK(3);
-    SSPUSHBOOL(*boolp);
+    SSCHECK(2);
     SSPUSHPTR(boolp);
-    SSPUSHINT(SAVEt_BOOL);
+    SSPUSHUV(SAVEt_BOOL | (*boolp << 8));
 }
 
 void
@@ -378,17 +385,23 @@ Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
     SSCHECK(3);
     SSPUSHINT(i);
     SSPUSHPTR(ptr);
-    SSPUSHINT(type);
+    SSPUSHUV(type);
 }
 
 void
 Perl_save_int(pTHX_ int *intp)
 {
     dVAR;
+    const UV shifted = (UV)*intp << SAVE_TIGHT_SHIFT;
 
     PERL_ARGS_ASSERT_SAVE_INT;
 
-    save_pushi32ptr(*intp, intp, SAVEt_INT);
+    if ((int)(shifted >> SAVE_TIGHT_SHIFT) == *intp) {
+	SSCHECK(2);
+	SSPUSHPTR(intp);
+	SSPUSHUV(SAVEt_INT_SMALL | shifted);
+    } else
+	save_pushi32ptr(*intp, intp, SAVEt_INT);
 }
 
 void
@@ -398,7 +411,9 @@ Perl_save_I8(pTHX_ I8 *bytep)
 
     PERL_ARGS_ASSERT_SAVE_I8;
 
-    save_pushi32ptr(*bytep, bytep, SAVEt_I8);
+    SSCHECK(2);
+    SSPUSHPTR(bytep);
+    SSPUSHUV(SAVEt_I8 | ((UV)*bytep << 8));
 }
 
 void
@@ -408,17 +423,25 @@ Perl_save_I16(pTHX_ I16 *intp)
 
     PERL_ARGS_ASSERT_SAVE_I16;
 
-    save_pushi32ptr(*intp, intp, SAVEt_I16);
+    SSCHECK(2);
+    SSPUSHPTR(intp);
+    SSPUSHUV(SAVEt_I16 | ((UV)*intp << 8));
 }
 
 void
 Perl_save_I32(pTHX_ I32 *intp)
 {
     dVAR;
+    const UV shifted = (UV)*intp << SAVE_TIGHT_SHIFT;
 
     PERL_ARGS_ASSERT_SAVE_I32;
 
-    save_pushi32ptr(*intp, intp, SAVEt_I32);
+    if ((I32)(shifted >> SAVE_TIGHT_SHIFT) == *intp) {
+	SSCHECK(2);
+	SSPUSHPTR(intp);
+	SSPUSHUV(SAVEt_I32_SMALL | shifted);
+    } else
+	save_pushi32ptr(*intp, intp, SAVEt_I32);
 }
 
 /* Cannot use save_sptr() to store a char* since the SV** cast will
@@ -463,7 +486,7 @@ Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
     SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
     SSPUSHPTR(PL_comppad);
     SSPUSHLONG((long)off);
-    SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE);
+    SSPUSHUV(SAVEt_PADSV_AND_MORTALIZE);
 }
 
 void
@@ -492,20 +515,25 @@ Perl_save_pushptr(pTHX_ void *const ptr, const int type)
     dVAR;
     SSCHECK(2);
     SSPUSHPTR(ptr);
-    SSPUSHINT(type);
+    SSPUSHUV(type);
 }
 
 void
 Perl_save_clearsv(pTHX_ SV **svp)
 {
     dVAR;
+    const UV offset = svp - PL_curpad;
+    const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
 
     PERL_ARGS_ASSERT_SAVE_CLEARSV;
 
     ASSERT_CURPAD_ACTIVE("save_clearsv");
-    SSCHECK(2);
-    SSPUSHLONG((long)(svp-PL_curpad));
-    SSPUSHINT(SAVEt_CLEARSV);
+    if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)
+	Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
+		   offset, svp, PL_curpad);
+
+    SSCHECK(1);
+    SSPUSHUV(offset_shifted | SAVEt_CLEARSV);
     SvPADSTALE_off(*svp); /* mark lexical as active */
 }
 
@@ -555,7 +583,7 @@ Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
     SSCHECK(3);
     SSPUSHDPTR(f);
     SSPUSHPTR(p);
-    SSPUSHINT(SAVEt_DESTRUCTOR);
+    SSPUSHUV(SAVEt_DESTRUCTOR);
 }
 
 void
@@ -565,7 +593,7 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
     SSCHECK(3);
     SSPUSHDXPTR(f);
     SSPUSHPTR(p);
-    SSPUSHINT(SAVEt_DESTRUCTOR_X);
+    SSPUSHUV(SAVEt_DESTRUCTOR_X);
 }
 
 void
@@ -594,7 +622,7 @@ S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
     SSPUSHPTR(ptr1);
     SSPUSHINT(i);
     SSPUSHPTR(ptr2);
-    SSPUSHINT(type);
+    SSPUSHUV(type);
 }
 
 void
@@ -619,7 +647,7 @@ Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
      * won't actually be stored in the array - so it won't get
      * reaped when the localize ends. Ensure it gets reaped by
      * mortifying it instead. DAPM */
-    if (SvTIED_mg(av, PERL_MAGIC_tied))
+    if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 	sv_2mortal(sv);
 }
 
@@ -636,7 +664,7 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
     SSPUSHPTR(SvREFCNT_inc_simple(hv));
     SSPUSHPTR(newSVsv(key));
     SSPUSHPTR(SvREFCNT_inc(*sptr));
-    SSPUSHINT(SAVEt_HELEM);
+    SSPUSHUV(SAVEt_HELEM);
     save_scalar_at(sptr, flags);
     if (flags & SAVEf_KEEPOLDELEM)
 	return;
@@ -645,7 +673,7 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
      * won't actually be stored in the hash - so it won't get
      * reaped when the localize ends. Ensure it gets reaped by
      * mortifying it instead. DAPM */
-    if (SvTIED_mg(hv, PERL_MAGIC_tied))
+    if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
 	sv_2mortal(sv);
 }
 
@@ -667,13 +695,17 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad)
     dVAR;
     register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
 				- (char*)PL_savestack);
-    register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
+    const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
+    const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
 
-    SSGROW(elems + 2);
+    if ((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)
+	Perl_croak(aTHX_ "panic: save_alloc elems %"UVuf" out of range (%ld-%ld)",
+		   elems, size, pad);
+
+    SSGROW(elems + 1);
 
     PL_savestack_ix += elems;
-    SSPUSHINT(elems);
-    SSPUSHINT(SAVEt_ALLOC);
+    SSPUSHUV(SAVEt_ALLOC | elems_shifted);
     return start;
 }
 
@@ -697,9 +729,11 @@ Perl_leave_scope(pTHX_ I32 base)
     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
 			(long)PL_savestack_ix, (long)base));
     while (PL_savestack_ix > base) {
+	UV uv = SSPOPUV;
+	const U8 type = (U8)uv & SAVE_MASK;
 	TAINT_NOT;
 
-	switch (SSPOPINT) {
+	switch (type) {
 	case SAVEt_ITEM:			/* normal string */
 	    value = MUTABLE_SV(SSPOPPTR);
 	    sv = MUTABLE_SV(SSPOPPTR);
@@ -744,9 +778,15 @@ Perl_leave_scope(pTHX_ I32 base)
 		*(char**)ptr = str;
 	    }
 	    break;
+	case SAVEt_GVSV:			/* scalar slot in GV */
+	    value = MUTABLE_SV(SSPOPPTR);
+	    gv = MUTABLE_GV(SSPOPPTR);
+	    ptr = &GvSV(gv);
+	    goto restore_svp;
 	case SAVEt_GENERIC_SVREF:		/* generic sv */
 	    value = MUTABLE_SV(SSPOPPTR);
 	    ptr = SSPOPPTR;
+	restore_svp:
 	    sv = *(SV**)ptr;
 	    *(SV**)ptr = value;
 	    SvREFCNT_dec(sv);
@@ -774,13 +814,21 @@ Perl_leave_scope(pTHX_ I32 base)
 		PL_localizing = 0;
 	    }
 	    break;
+	case SAVEt_INT_SMALL:
+	    ptr = SSPOPPTR;
+	    *(int*)ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
+	    break;
 	case SAVEt_INT:				/* int reference */
 	    ptr = SSPOPPTR;
 	    *(int*)ptr = (int)SSPOPINT;
 	    break;
 	case SAVEt_BOOL:			/* bool reference */
 	    ptr = SSPOPPTR;
-	    *(bool*)ptr = (bool)SSPOPBOOL;
+	    *(bool*)ptr = cBOOL(uv >> 8);
+	    break;
+	case SAVEt_I32_SMALL:
+	    ptr = SSPOPPTR;
+	    *(I32*)ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
 	    break;
 	case SAVEt_I32:				/* I32 reference */
 	    ptr = SSPOPPTR;
@@ -812,10 +860,11 @@ Perl_leave_scope(pTHX_ I32 base)
 	    *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
 	    break;
 	case SAVEt_GP:				/* scalar reference */
-	    ptr = SSPOPPTR;
 	    gv = MUTABLE_GV(SSPOPPTR);
 	    gp_free(gv);
-	    GvGP(gv) = (GP*)ptr;
+	    GvGP(gv) = (GP*)SSPOPPTR;
+	    if (SSPOPINT)
+		SvFAKE_on(gv);
             /* putting a method back into circulation ("local")*/
 	    if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
                 mro_method_changed_in(hv);
@@ -839,7 +888,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    Safefree(ptr);
 	    break;
 	case SAVEt_CLEARSV:
-	    ptr = (void*)&PL_curpad[SSPOPLONG];
+	    ptr = (void*)&PL_curpad[uv >> SAVE_TIGHT_SHIFT];
 	    sv = *(SV**)ptr;
 
 	    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
@@ -915,9 +964,9 @@ Perl_leave_scope(pTHX_ I32 base)
 	    (*SSPOPDXPTR)(aTHX_ ptr);
 	    break;
 	case SAVEt_REGCONTEXT:
+	    /* regexp must have croaked */
 	case SAVEt_ALLOC:
-	    i = SSPOPINT;
-	    PL_savestack_ix -= i;  	/* regexp must have croaked */
+	    PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
 	    break;
 	case SAVEt_STACK_POS:		/* Position on Perl stack */
 	    i = SSPOPINT;
@@ -1065,11 +1114,11 @@ Perl_leave_scope(pTHX_ I32 base)
 
 	case SAVEt_I16:				/* I16 reference */
 	    ptr = SSPOPPTR;
-	    *(I16*)ptr = (I16)SSPOPINT;
+	    *(I16*)ptr = (I16)(uv >> 8);
 	    break;
 	case SAVEt_I8:				/* I8 reference */
 	    ptr = SSPOPPTR;
-	    *(I8*)ptr = (I8)SSPOPINT;
+	    *(I8*)ptr = (I8)(uv >> 8);
 	    break;
 	case SAVEt_DESTRUCTOR:
 	    ptr = SSPOPPTR;
@@ -1115,6 +1164,8 @@ Perl_leave_scope(pTHX_ I32 base)
     }
 
     PL_tainted = was;
+
+    PERL_ASYNC_CHECK();
 }
 
 void
@@ -1187,8 +1238,6 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		(long)cx->blk_loop.resetsp);
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
 		PTR2UV(cx->blk_loop.my_op));
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
-		PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
 	/* XXX: not accurate for LAZYSV/IV */
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
 		PTR2UV(cx->blk_loop.state_u.ary.ary));