#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
-#if defined(PL_OP_SLAB_ALLOC)
+/* See the explanatory comments above struct opslab in op.h. */
#ifdef PERL_DEBUG_READONLY_OPS
-# define PERL_SLAB_SIZE 4096
+# define PERL_SLAB_SIZE 128
+# define PERL_MAX_SLAB_SIZE 4096
# include <sys/mman.h>
#endif
#ifndef PERL_SLAB_SIZE
-#define PERL_SLAB_SIZE 2048
-#endif
-
-void *
-Perl_Slab_Alloc(pTHX_ size_t sz)
-{
- dVAR;
- /*
- * To make incrementing use count easy PL_OpSlab is an I32 *
- * To make inserting the link to slab PL_OpPtr is I32 **
- * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
- * Add an overhead for pointer to slab and round up as a number of pointers
- */
- sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
- if ((PL_OpSpace -= sz) < 0) {
-#ifdef PERL_DEBUG_READONLY_OPS
- /* We need to allocate chunk by chunk so that we can control the VM
- mapping */
- PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0);
-
- DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
- (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
- PL_OpPtr));
- if(PL_OpPtr == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
-#else
-
- PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
-#endif
- if (!PL_OpPtr) {
- return NULL;
- }
- /* We reserve the 0'th I32 sized chunk as a use count */
- PL_OpSlab = (I32 *) PL_OpPtr;
- /* Reduce size by the use count word, and by the size we need.
- * Latter is to mimic the '-=' in the if() above
- */
- PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
- /* Allocation pointer starts at the top.
- Theory: because we build leaves before trunk allocating at end
- means that at run time access is cache friendly upward
- */
- PL_OpPtr += PERL_SLAB_SIZE;
-
-#ifdef PERL_DEBUG_READONLY_OPS
- /* We remember this slab. */
- /* This implementation isn't efficient, but it is simple. */
- PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
- PL_slabs[PL_slab_count++] = PL_OpSlab;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
-#endif
- }
- assert( PL_OpSpace >= 0 );
- /* Move the allocation pointer down */
- PL_OpPtr -= sz;
- assert( PL_OpPtr > (I32 **) PL_OpSlab );
- *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
- (*PL_OpSlab)++; /* Increment use count of slab */
- assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
- assert( *PL_OpSlab > 0 );
- return (void *)(PL_OpPtr + 1);
-}
-
-#ifdef PERL_DEBUG_READONLY_OPS
-void
-Perl_pending_Slabs_to_ro(pTHX) {
- /* Turn all the allocated op slabs read only. */
- U32 count = PL_slab_count;
- I32 **const slabs = PL_slabs;
-
- /* Reset the array of pending OP slabs, as we're about to turn this lot
- read only. Also, do it ahead of the loop in case the warn triggers,
- and a warn handler has an eval */
-
- PL_slabs = NULL;
- PL_slab_count = 0;
-
- /* Force a new slab for any further allocation. */
- PL_OpSpace = 0;
-
- while (count--) {
- void *const start = slabs[count];
- const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
- if(mprotect(start, size, PROT_READ)) {
- Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
- start, (unsigned long) size, errno);
- }
- }
-
- free(slabs);
-}
-
-STATIC void
-S_Slab_to_rw(pTHX_ void *op)
-{
- I32 * const * const ptr = (I32 **) op;
- I32 * const slab = ptr[-1];
-
- PERL_ARGS_ASSERT_SLAB_TO_RW;
-
- assert( ptr-1 > (I32 **) slab );
- assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
- assert( *slab > 0 );
- if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
- Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
- slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
- }
-}
-
-OP *
-Perl_op_refcnt_inc(pTHX_ OP *o)
-{
- if(o) {
- Slab_to_rw(o);
- ++o->op_targ;
- }
- return o;
-
-}
-
-PADOFFSET
-Perl_op_refcnt_dec(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_OP_REFCNT_DEC;
- Slab_to_rw(o);
- return --o->op_targ;
-}
-#else
-# define Slab_to_rw(op)
-#endif
-
-void
-Perl_Slab_Free(pTHX_ void *op)
-{
- I32 * const * const ptr = (I32 **) op;
- I32 * const slab = ptr[-1];
- PERL_ARGS_ASSERT_SLAB_FREE;
- assert( ptr-1 > (I32 **) slab );
- assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
- assert( *slab > 0 );
- Slab_to_rw(op);
- if (--(*slab) == 0) {
-# ifdef NETWARE
-# define PerlMemShared PerlMem
-# endif
-
-#ifdef PERL_DEBUG_READONLY_OPS
- U32 count = PL_slab_count;
- /* Need to remove this slab from our list of slabs */
- if (count) {
- while (count--) {
- if (PL_slabs[count] == slab) {
- dVAR;
- /* Found it. Move the entry at the end to overwrite it. */
- DEBUG_m(PerlIO_printf(Perl_debug_log,
- "Deallocate %p by moving %p from %lu to %lu\n",
- PL_OpSlab,
- PL_slabs[PL_slab_count - 1],
- PL_slab_count, count));
- PL_slabs[count] = PL_slabs[--PL_slab_count];
- /* Could realloc smaller at this point, but probably not
- worth it. */
- if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
- perror("munmap failed");
- abort();
- }
- break;
- }
- }
- }
-#else
- PerlMemShared_free(slab);
-#endif
- if (slab == PL_OpSlab) {
- PL_OpSpace = 0;
- }
- }
-}
-#else /* !defined(PL_OP_SLAB_ALLOC) */
-
-/* See the explanatory comments above struct opslab in op.h. */
-
-# ifndef PERL_SLAB_SIZE
# define PERL_SLAB_SIZE 64
-# endif
-# ifndef PERL_MAX_SLAB_SIZE
+#endif
+#ifndef PERL_MAX_SLAB_SIZE
# define PERL_MAX_SLAB_SIZE 2048
-# endif
+#endif
/* rounds up to nearest pointer */
-# define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
-# define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
static OPSLAB *
S_new_slab(pTHX_ size_t sz)
{
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+ PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0);
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
+ (unsigned long) sz, slab));
+ if (slab == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ slab->opslab_size = (U16)sz;
+#else
OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+#endif
slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
return slab;
}
}
}
-# define INIT_OPSLOT \
+#define INIT_OPSLOT \
slot->opslot_slab = slab; \
slot->opslot_next = slab2->opslab_first; \
slab2->opslab_first = slot; \
/* Create a new slab. Make this one twice as big. */
slot = slab2->opslab_first;
while (slot->opslot_next) slot = slot->opslot_next;
- slab2 = S_new_slab(aTHX_ DIFF(slab2, slot)*2 > PERL_MAX_SLAB_SIZE
+ slab2 = S_new_slab(aTHX_
+ (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
? PERL_MAX_SLAB_SIZE
- : DIFF(slab2, slot)*2);
+ : (DIFF(slab2, slot)+1)*2);
slab2->opslab_next = slab->opslab_next;
slab->opslab_next = slab2;
}
return (void *)o;
}
-# undef INIT_OPSLOT
+#undef INIT_OPSLOT
+
+#ifdef PERL_DEBUG_READONLY_OPS
+void
+Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
+{
+ PERL_ARGS_ASSERT_SLAB_TO_RO;
+
+ if (slab->opslab_readonly) return;
+ slab->opslab_readonly = 1;
+ for (; slab; slab = slab->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
+ (unsigned long) slab->opslab_size, slab));*/
+ if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+ (unsigned long)slab->opslab_size, errno);
+ }
+}
+
+STATIC void
+S_Slab_to_rw(pTHX_ void *op)
+{
+ OP * const o = (OP *)op;
+ OPSLAB *slab;
+ OPSLAB *slab2;
+
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
+
+ if (!o->op_slabbed) return;
+
+ slab = OpSLAB(o);
+ if (!slab->opslab_readonly) return;
+ slab2 = slab;
+ for (; slab2; slab2 = slab2->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
+ (unsigned long) size, slab2));*/
+ if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+ PROT_READ|PROT_WRITE)) {
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+ (unsigned long)slab2->opslab_size, errno);
+ }
+ }
+ slab->opslab_readonly = 0;
+}
+
+#else
+# define Slab_to_rw(op)
+#endif
/* This cannot possibly be right, but it was copied from the old slab
allocator, to which it was originally added, without explanation, in
commit 083fcd5. */
-# ifdef NETWARE
+#ifdef NETWARE
# define PerlMemShared PerlMem
-# endif
+#endif
void
Perl_Slab_Free(pTHX_ void *op)
assert(slab->opslab_refcnt == 1);
for (; slab; slab = slab2) {
slab2 = slab->opslab_next;
-# ifdef DEBUGGING
+#ifdef DEBUGGING
slab->opslab_refcnt = ~(size_t)0;
-# endif
+#endif
+#ifdef PERL_DEBUG_READONLY_OPS
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
+ slab));
+ if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+ perror("munmap failed");
+ abort();
+ }
+#else
PerlMemShared_free(slab);
+#endif
}
}
{
OPSLAB *slab2;
OPSLOT *slot;
-# ifdef DEBUGGING
+#ifdef DEBUGGING
size_t savestack_count = 0;
-# endif
+#endif
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
slot = slot->opslot_next) {
if (slot->opslot_op.op_type != OP_FREED
&& !(slot->opslot_op.op_savefree
-# ifdef DEBUGGING
+#ifdef DEBUGGING
&& ++savestack_count
-# endif
+#endif
)
) {
assert(slot->opslot_op.op_slabbed);
} while ((slab2 = slab2->opslab_next));
/* > 1 because the CV still holds a reference count. */
if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
-# ifdef DEBUGGING
+#ifdef DEBUGGING
assert(savestack_count == slab->opslab_refcnt-1);
-# endif
+#endif
return;
}
free:
opslab_free(slab);
}
+#ifdef PERL_DEBUG_READONLY_OPS
+OP *
+Perl_op_refcnt_inc(pTHX_ OP *o)
+{
+ if(o) {
+ Slab_to_rw(o);
+ ++o->op_targ;
+ }
+ return o;
+
+}
+
+PADOFFSET
+Perl_op_refcnt_dec(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_OP_REFCNT_DEC;
+ Slab_to_rw(o);
+ return --o->op_targ;
+}
#endif
/*
* In the following definition, the ", (OP*)0" is just to make the compiler
static void
S_op_destroy(pTHX_ OP *o)
{
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
FreeOp(o);
}
dVAR;
OPCODE type;
-#ifndef PL_OP_SLAB_ALLOC
/* Though ops may be freed twice, freeing the op after its slab is a
big no-no. */
assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
-#endif
/* During the forced freeing of ops after compilation failure, kidops
may be freed before their parents. */
if (!o || o->op_type == OP_FREED)
return;
- if (o->op_latefreed) {
- if (o->op_latefree)
- return;
- goto do_free;
- }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
CALL_OPFREEHOOK(o);
if (o->op_flags & OPf_KIDS) {
- register OP *kid, *nextkid;
+ OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
op_free(kid);
}
}
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
-#ifdef PERL_DEBUG_READONLY_OPS
Slab_to_rw(o);
-#endif
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE
- || (type == OP_NULL /* the COP might have been null'ed */
- && ((OPCODE)o->op_targ == OP_NEXTSTATE
- || (OPCODE)o->op_targ == OP_DBSTATE))) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
-
op_clear(o);
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
- do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
}
#endif
break;
+ case OP_DUMP:
case OP_GOTO:
case OP_NEXT:
case OP_LAST:
case OP_TRANS:
case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+ assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
/* establish postfix order */
first = cUNOPo->op_first;
if (first) {
- register OP *kid;
+ OP *kid;
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
{
dVAR;
OP *kid;
+ SV *useless_sv = NULL;
const char* useless = NULL;
- U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
useless = NULL;
else {
SV * const dsv = newSVpvs("");
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, maybe_macro,
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
SvREFCNT_dec(dsv);
- useless = SvPV_nolen(msv);
- useless_is_utf8 = SvUTF8(msv);
}
}
else if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
}
else
useless = "a constant (undef)";
case OP_SCALAR:
return scalar(o);
}
- if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
- newSVpvn_flags(useless, strlen(useless),
- SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
+
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ sv_2mortal(useless_sv));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
return o;
}
return o;
}
+OP *
+Perl_op_unscope(pTHX_ OP *o)
+{
+ if (o && o->op_type == OP_LINESEQ) {
+ OP *kid = cLISTOPo->op_first;
+ for(; kid; kid = kid->op_sibling)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
+ }
+ return o;
+}
+
int
Perl_block_start(pTHX_ int full)
{
S_fold_constants(pTHX_ register OP *o)
{
dVAR;
- register OP * VOL curop;
+ OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
if (IN_LOCALE_COMPILETIME)
goto nope;
break;
+ case OP_PACK:
+ if (!cLISTOPo->op_first->op_sibling
+ || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
+ goto nope;
+ {
+ SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
+ if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
+ {
+ const char *s = SvPVX_const(sv);
+ while (s < SvEND(sv)) {
+ if (*s == 'p' || *s == 'P') goto nope;
+ s++;
+ }
+ }
+ }
+ break;
case OP_REPEAT:
if (o->op_private & OPpREPEAT_DOLIST) goto nope;
}
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
op_getmad(o,newop,'f');
return newop;
S_gen_constant_list(pTHX_ register OP *o)
{
dVAR;
- register OP *curop;
+ OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
list(o);
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
- o->op_latefree = 0;
- o->op_latefreed = 0;
- o->op_attached = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const U8 *r = (U8*)SvPV_const(rstr, rlen);
- register I32 i;
- register I32 j;
+ I32 i;
+ I32 j;
I32 grows = 0;
- register short *tbl;
+ short *tbl;
const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
* pad_fixup_inner_anons() can find it */
(void)pad_add_anon(cv, o->op_type);
SvREFCNT_inc_simple_void(cv);
-
- cv_forget_slab(cv);
}
else {
pm->op_code_list = expr;
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
+ svop->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)svop);
if (PL_opargs[type] & OA_TARGET)
dVAR;
const U32 seq = intro_my();
const U32 utf8 = flags & SVf_UTF8;
- register COP *cop;
+ COP *cop;
flags &= ~SVf_UTF8;
CopLINE_set(cop, CopLINE(PL_curcop));
else {
CopLINE_set(cop, PL_parser->copline);
- if (PL_parser)
- PL_parser->copline = NOLINE;
+ PL_parser->copline = NOLINE;
}
#ifdef USE_ITHREADS
CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
+ else if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_FOLDED;
return other;
}
else {
|| live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
+ else if (live->op_type == OP_CONST)
+ live->op_private |= OPpCONST_FOLDED;
return live;
}
NewOp(1101, logop, 1, LOGOP);
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
loop->op_private = (U8)iterpflags;
-#ifndef PL_OP_SLAB_ALLOC
if (loop->op_slabbed
&& DIFF(loop, OpSLOT(loop)->opslot_next)
< SIZE_TO_PSIZE(sizeof(LOOP)))
-#endif
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
-#ifndef PL_OP_SLAB_ALLOC
else if (!loop->op_slabbed)
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#endif
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
if (madsv)
Constructs, checks, and returns a loop-exiting op (such as C<goto>
or C<last>). I<type> is the opcode. I<label> supplies the parameter
determining the target of the op; it is consumed by this function and
-become part of the constructed op tree.
+becomes part of the constructed op tree.
=cut
*/
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
dVAR;
- OP *o;
+ OP *o = NULL;
PERL_ARGS_ASSERT_NEWLOOPEX;
if (type != OP_GOTO) {
/* "last()" means "last" */
- if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
o = newOP(type, OPf_SPECIAL);
- else {
- const_label:
- o = newPVOP(type,
- label->op_type == OP_CONST
- ? SvUTF8(((SVOP*)label)->op_sv)
- : 0,
- savesharedpv(label->op_type == OP_CONST
- ? SvPV_nolen_const(((SVOP*)label)->op_sv)
- : ""));
}
-#ifdef PERL_MAD
- op_getmad(label,o,'L');
-#else
- op_free(label);
-#endif
}
else {
/* Check whether it's going to be a goto &function */
if (label->op_type == OP_ENTERSUB
&& !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
- else if (label->op_type == OP_CONST) {
+ }
+
+ /* Check for a constant argument */
+ if (label->op_type == OP_CONST) {
SV * const sv = ((SVOP *)label)->op_sv;
STRLEN l;
const char *s = SvPV_const(sv,l);
- if (l == strlen(s)) goto const_label;
- }
- o = newUNOP(type, OPf_STACKED, label);
+ if (l == strlen(s)) {
+ o = newPVOP(type,
+ SvUTF8(((SVOP*)label)->op_sv),
+ savesharedpv(
+ SvPV_nolen_const(((SVOP*)label)->op_sv)));
+ }
}
+
+ /* If we have already created an op, we do not need the label. */
+ if (o)
+#ifdef PERL_MAD
+ op_getmad(label,o,'L');
+#else
+ op_free(label);
+#endif
+ else o = newUNOP(type, OPf_STACKED, label);
+
PL_hints |= HINT_BLOCK_SCOPE;
return o;
}
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
- const char * const cvp = CvPROTO(cv);
+ const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
const STRLEN clen = CvPROTOLEN(cv);
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
SV* name = NULL;
if (gv)
+ {
+ if (isGV(gv))
gv_efullname3(name = sv_newmortal(), gv, NULL);
+ else name = (SV *)gv;
+ }
sv_setpvs(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
- if (SvPOK(cv))
+ if (cvp)
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
);
*
* We have just cloned an anon prototype that was marked as a const
* candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. Return the value.
+ * PADSV, ignore it if it has multiple references. In this case we
+ * return a newly created *copy* of the value.
*/
SV *
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- register CV *cv = NULL;
+ CV *cv = NULL;
SV *const_sv;
const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
if (proto) {
assert(proto->op_type == OP_CONST);
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8);
}
if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
- AV *const temp_av = CvPADLIST(cv);
+ PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
- const cv_flags_t slabbed = CvSLABBED(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
OP * const cvstart = CvSTART(cv);
- assert(!CvWEAKOUTSIDE(cv));
+ CvGV_set(cv,gv);
assert(!CvCVGV_RC(cv));
assert(CvGV(cv) == gv);
CvPADLIST(PL_compcv) = temp_av;
CvSTART(cv) = CvSTART(PL_compcv);
CvSTART(PL_compcv) = cvstart;
- if (slabbed) CvSLABBED_on(PL_compcv);
- else CvSLABBED_off(PL_compcv);
+ CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(PL_compcv) |= other_flags;
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
#endif
block = newblock;
}
- else block->op_attached = 1;
CvROOT(cv) = CvLVALUE(cv)
? newUNOP(OP_LEAVESUBLV, 0,
op_lvalue(scalarseq(block), OP_LEAVESUBLV))
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
-#ifndef PL_OP_SLAB_ALLOC
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
itself has a refcount. */
CvSLABBED_off(cv);
OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
#endif
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* Watch out for BEGIN blocks */
+ if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+#endif
return cv;
}
Currently, the only useful value for C<flags> is SVf_UTF8.
+The newly created subroutine takes ownership of a reference to the passed in
+SV.
+
Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
CV *
Perl_newSTUB(pTHX_ GV *gv, bool fake)
{
- register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
PERL_ARGS_ASSERT_NEWSTUB;
assert(!GvCVu(gv));
GvCV_set(gv, cv);
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
dVAR;
- register CV *cv;
+ CV *cv;
#ifdef PERL_MAD
OP* pegop = newOP(OP_NULL, 0);
#endif
- GV * const gv = o
+ GV *gv;
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ goto finish;
+ }
+
+ gv = o
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
SvREFCNT_dec(cv);
}
cv = PL_compcv;
- GvFORM(gv) = cv;
+ GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
cv_forget_slab(cv);
+
+ finish:
#ifdef PERL_MAD
op_getmad(o,pegop,'n');
op_getmad_weak(block, pegop, 'b');
SVOP * const kid = (SVOP*)cUNOPo->op_first;
const OPCODE kidtype = kid->op_type;
- if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
+ && !(kid->op_private & OPpCONST_FOLDED)) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
{
dVAR;
const int type = o->op_type;
- register I32 oa = PL_opargs[type] >> OASHIFT;
+ I32 oa = PL_opargs[type] >> OASHIFT;
PERL_ARGS_ASSERT_CK_FUN;
if (o->op_flags & OPf_KIDS) {
OP **tokid = &cLISTOPo->op_first;
- register OP *kid = cLISTOPo->op_first;
+ OP *kid = cLISTOPo->op_first;
OP *sibl;
I32 numargs = 0;
bool seen_optional = FALSE;
{
OP * const newop = newUNOP(OP_NULL, 0, kid);
kid->op_sibling = 0;
- LINKLIST(kid);
newop->op_next = newop;
kid = newop;
kid->op_sibling = sibl;
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop = NULL;
+ LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
PADOFFSET offset;
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
- OP* k;
- o = ck_sort(o);
kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
return no_fh_allowed(o);
- for (k = kid; k; k = k->op_next) {
- kid = k;
- }
- NewOp(1101, gwop, 1, LOGOP);
- kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
kid = cLISTOPo->op_first->op_sibling;
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- if (!gwop)
- NewOp(1101, gwop, 1, LOGOP);
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
- gwop->op_first = listkids(o);
+ gwop->op_first = o;
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
}
kid = cLISTOPo->op_first->op_sibling;
- if (!kid || !kid->op_sibling)
- return too_few_arguments_pv(o,OP_DESC(o), 0);
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_GREPSTART);
OP *
Perl_ck_listiob(pTHX_ OP *o)
{
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_LISTIOB;
if (kid && o->op_flags & OPf_STACKED)
kid = kid->op_sibling;
else if (kid && !kid->op_sibling) { /* print HANDLE; */
- if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
+ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
+ && !(kid->op_private & OPpCONST_FOLDED)) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
cLISTOPo->op_first->op_sibling = kid;
{
dVAR;
OP *firstkid;
+ HV * const hinthv = GvHV(PL_hintgv);
PERL_ARGS_ASSERT_CK_SORT;
- if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
- HV * const hinthv = GvHV(PL_hintgv);
- if (hinthv) {
+ if (hinthv) {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
}
- }
}
- if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
- OP *k = NULL;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
LINKLIST(kid);
- if (kid->op_type == OP_SCOPE) {
- k = kid->op_next;
- kid->op_next = 0;
- }
- else if (kid->op_type == OP_LEAVE) {
- if (o->op_type == OP_SORT) {
+ if (kid->op_type == OP_LEAVE)
op_null(kid); /* wipe out leave */
- kid->op_next = kid;
-
- for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
- if (k->op_next == kid)
- k->op_next = 0;
- /* don't descend into loops */
- else if (k->op_type == OP_ENTERLOOP
- || k->op_type == OP_ENTERITER)
- {
- k = cLOOPx(k)->op_lastop;
- }
- }
- }
- else
- kid->op_next = 0; /* just disconnect the leave */
- k = kLISTOP->op_first;
- }
- CALL_PEEP(k);
+ /* Prevent execution from escaping out of the sort block. */
+ kid->op_next = 0;
- kid = firstkid;
- if (o->op_type == OP_SORT) {
- /* provide scalar context for comparison function/block */
- kid = scalar(kid);
- kid->op_next = kid;
- }
- else
- kid->op_next = k;
+ /* provide scalar context for comparison function/block */
+ kid = scalar(firstkid);
+ kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
}
/* provide list context for arguments */
- if (o->op_type == OP_SORT)
- list(firstkid);
+ list(firstkid);
return o;
}
S_simplify_sort(pTHX_ OP *o)
{
dVAR;
- register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int descending;
GV *gv;
SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
if (SvCUR(name) == 2 && *SvPVX(name) == '$'
&& (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
+ /* diag_listed_as: "my %s" used in sort comparison */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\"my %s\" used in sort comparison",
+ "\"%s %s\" used in sort comparison",
+ SvPAD_STATE(name) ? "state" : "my",
SvPVX(name));
}
} while ((kid = kid->op_sibling));
Perl_ck_split(pTHX_ OP *o)
{
dVAR;
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_SPLIT;
}
OP *
-Perl_ck_chdir(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_CHDIR;
- if (o->op_flags & OPf_KIDS) {
- SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- o->op_flags |= OPf_SPECIAL;
- kid->op_private &= ~OPpCONST_STRICT;
- }
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_trunc(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_TRUNC;
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
+ (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
+ == OPpCONST_BARE)
{
o->op_flags |= OPf_SPECIAL;
kid->op_private &= ~OPpCONST_STRICT;
return o;
}
-/* caller is supposed to assign the return to the
- container of the rep_op var */
-STATIC OP *
-S_opt_scalarhv(pTHX_ OP *rep_op) {
- dVAR;
- UNOP *unop;
-
- PERL_ARGS_ASSERT_OPT_SCALARHV;
-
- NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)OP_BOOLKEYS;
- unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
- unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
- unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
- unop->op_first = rep_op;
- unop->op_next = rep_op->op_next;
- rep_op->op_next = (OP*)unop;
- rep_op->op_flags|=(OPf_REF | OPf_MOD);
- unop->op_sibling = rep_op->op_sibling;
- rep_op->op_sibling = NULL;
- /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
- if (rep_op->op_type == OP_PADHV) {
- rep_op->op_flags &= ~OPf_WANT_SCALAR;
- rep_op->op_flags |= OPf_WANT_LIST;
- }
- return (OP*)unop;
-}
-
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
#define MAX_DEFERRED 4
#define DEFER(o) \
+ STMT_START { \
if (defer_ix == (MAX_DEFERRED-1)) { \
CALL_RPEEP(defer_queue[defer_base]); \
defer_base = (defer_base + 1) % MAX_DEFERRED; \
defer_ix--; \
} \
- defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
+ } STMT_END
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
Perl_rpeep(pTHX_ register OP *o)
{
dVAR;
- register OP* oldop = NULL;
+ OP* oldop = NULL;
OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
stitch_keys:
o->op_opt = 1;
- if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- || ( sop &&
- (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
- )
+#define HV_OR_SCALARHV(op) \
+ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
+ ? (op) \
+ : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
+ && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
+ || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
+ ? cUNOPx(op)->op_first \
+ : NULL)
+
+ fop = HV_OR_SCALARHV(fop);
+ if (sop) sop = HV_OR_SCALARHV(sop);
+ if (fop || sop
){
OP * nop = o;
OP * lop = o;
}
}
}
- if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
- if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- cLOGOP->op_first = opt_scalarhv(fop);
- if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
- cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
- }
+ if (fop) {
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ || o->op_type == OP_AND )
+ fop->op_private |= OPpTRUEBOOL;
+ else if (!(lop->op_flags & OPf_WANT))
+ fop->op_private |= OPpMAYBE_TRUEBOOL;
+ }
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && sop)
+ sop->op_private |= OPpTRUEBOOL;
}
break;
- }
+ case OP_COND_EXPR:
+ if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
+ fop->op_private |= OPpMAYBE_TRUEBOOL;
+#undef HV_OR_SCALARHV
+ /* GERONIMO! */
+ }
+
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
- case OP_COND_EXPR:
case OP_RANGE:
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
break;
case OP_SORT: {
+ OP *oright;
+
+ if (o->op_flags & OPf_STACKED) {
+ OP * const kid =
+ cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
+ if (kid->op_type == OP_SCOPE
+ || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
+ DEFER(kLISTOP->op_first);
+ }
+
/* check that RHS of sort is a single plain array */
- OP *oright = cUNOPo->op_first;
+ oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;