X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/188c19101137d65e1d1aa0bc4df26a0e6287f97d..06b58b76f31:/op.c diff --git a/op.c b/op.c index cd5b0a7..b433227 100644 --- a/op.c +++ b/op.c @@ -109,126 +109,299 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #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 #endif #ifndef PERL_SLAB_SIZE -#define PERL_SLAB_SIZE 2048 +# define PERL_SLAB_SIZE 64 #endif +#ifndef PERL_MAX_SLAB_SIZE +# define PERL_MAX_SLAB_SIZE 2048 +#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))) + +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; +} + +/* requires double parens and aTHX_ */ +#define DEBUG_S_warn(args) \ + DEBUG_S( \ + PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ + ) 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) { + OPSLAB *slab; + OPSLAB *slab2; + OPSLOT *slot; + OP *o; + size_t opsz, space; + + if (!PL_compcv || CvROOT(PL_compcv) + || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) + return PerlMemShared_calloc(1, sz); + + if (!CvSTART(PL_compcv)) { /* sneak it in here */ + CvSTART(PL_compcv) = + (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + } + else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; + + opsz = SIZE_TO_PSIZE(sz); + sz = opsz + OPSLOT_HEADER_P; + + if (slab->opslab_freed) { + OP **too = &slab->opslab_freed; + o = *too; + DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab)); + while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { + DEBUG_S_warn((aTHX_ "Alas! too small")); + o = *(too = &o->op_next); + if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); } + } + if (o) { + *too = o->op_next; + Zero(o, opsz, I32 *); + o->op_slabbed = 1; + return (void *)o; + } + } + +#define INIT_OPSLOT \ + slot->opslot_slab = slab; \ + slot->opslot_next = slab2->opslab_first; \ + slab2->opslab_first = slot; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 + + /* The partially-filled slab is next in the chain. */ + slab2 = slab->opslab_next ? slab->opslab_next : slab; + if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { + /* Remaining space is too small. */ + + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { + slot = &slab2->opslab_slots; + INIT_OPSLOT; + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + } + + /* 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)+1)*2 > PERL_MAX_SLAB_SIZE + ? PERL_MAX_SLAB_SIZE + : (DIFF(slab2, slot)+1)*2); + slab2->opslab_next = slab->opslab_next; + slab->opslab_next = slab2; + } + assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); + + /* Create a new op slot */ + slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz); + assert(slot >= &slab2->opslab_slots); + if (DIFF(&slab2->opslab_slots, slot) + < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) + slot = &slab2->opslab_slots; + INIT_OPSLOT; + DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab)); + return (void *)o; +} + +#undef INIT_OPSLOT + #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 +void +Perl_Slab_to_ro(pTHX_ OPSLAB *slab) +{ + PERL_ARGS_ASSERT_SLAB_TO_RO; - 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; + 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); + } +} -#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 +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); + } } - 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); + slab->opslab_readonly = 0; } -#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; +#else +# define Slab_to_rw(op) +#endif - /* 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 */ +/* 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 +# define PerlMemShared PerlMem +#endif - PL_slabs = NULL; - PL_slab_count = 0; +void +Perl_Slab_Free(pTHX_ void *op) +{ + dVAR; + OP * const o = (OP *)op; + OPSLAB *slab; - /* Force a new slab for any further allocation. */ - PL_OpSpace = 0; + PERL_ARGS_ASSERT_SLAB_FREE; - 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); - } + if (!o->op_slabbed) { + PerlMemShared_free(op); + return; } - free(slabs); + slab = OpSLAB(o); + /* If this op is already freed, our refcount will get screwy. */ + assert(o->op_type != OP_FREED); + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab)); + OpslabREFCNT_dec_padok(slab); } -STATIC void -S_Slab_to_rw(pTHX_ void *op) +void +Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) { - I32 * const * const ptr = (I32 **) op; - I32 * const slab = ptr[-1]; + dVAR; + const bool havepad = !!PL_comppad; + PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; + if (havepad) { + ENTER; + PAD_SAVE_SETNULLPAD(); + } + opslab_free(slab); + if (havepad) LEAVE; +} - PERL_ARGS_ASSERT_SLAB_TO_RW; +void +Perl_opslab_free(pTHX_ OPSLAB *slab) +{ + dVAR; + OPSLAB *slab2; + PERL_ARGS_ASSERT_OPSLAB_FREE; + DEBUG_S_warn((aTHX_ "freeing slab %p", slab)); + assert(slab->opslab_refcnt == 1); + for (; slab; slab = slab2) { + slab2 = slab->opslab_next; +#ifdef DEBUGGING + slab->opslab_refcnt = ~(size_t)0; +#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 + } +} - 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); +void +Perl_opslab_force_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + OPSLOT *slot; +#ifdef DEBUGGING + size_t savestack_count = 0; +#endif + PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; + slab2 = slab; + do { + for (slot = slab2->opslab_first; + slot->opslot_next; + slot = slot->opslot_next) { + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree +#ifdef DEBUGGING + && ++savestack_count +#endif + ) + ) { + assert(slot->opslot_op.op_slabbed); + slab->opslab_refcnt++; /* op_free may free slab */ + op_free(&slot->opslot_op); + if (!--slab->opslab_refcnt) goto free; + } + } + } 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 + assert(savestack_count == slab->opslab_refcnt-1); +#endif + return; } + free: + opslab_free(slab); } +#ifdef PERL_DEBUG_READONLY_OPS OP * Perl_op_refcnt_inc(pTHX_ OP *o) { @@ -247,57 +420,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) 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; - } - } -} #endif /* * In the following definition, the ", (OP*)0" is just to make the compiler @@ -509,10 +631,6 @@ Perl_alloccopstash(pTHX_ HV *hv) static void S_op_destroy(pTHX_ OP *o) { - if (o->op_latefree) { - o->op_latefreed = 1; - return; - } FreeOp(o); } @@ -530,13 +648,13 @@ Perl_op_free(pTHX_ OP *o) dVAR; OPCODE type; - if (!o) + /* 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); + /* 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) { @@ -577,29 +695,18 @@ Perl_op_free(pTHX_ OP *o) 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) @@ -701,6 +808,7 @@ Perl_op_clear(pTHX_ OP *o) } #endif break; + case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: @@ -743,7 +851,8 @@ Perl_op_clear(pTHX_ OP *o) case OP_MATCH: case OP_QR: clear_pmop: - op_free(cPMOPo->op_code_list); + if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) + op_free(cPMOPo->op_code_list); cPMOPo->op_code_list = NULL; forget_pmop(cPMOPo, 1); cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; @@ -2471,11 +2580,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); return o; - } else if (type == OP_UNDEF -#ifdef PERL_MAD - || type == OP_STUB -#endif - ) { + } else if (type == OP_UNDEF || type == OP_STUB) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || @@ -2826,9 +2931,6 @@ Perl_newPROG(pTHX_ OP *o) else scalar(PL_eval_root); - /* don't use LINKLIST, since PL_eval_root might indirect through - * a rather expensive function call and LINKLIST evaluates its - * argument more than once */ PL_eval_start = op_linklist(PL_eval_root); PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); @@ -2856,6 +2958,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); + cv_forget_slab(PL_compcv); PL_compcv = 0; /* Register with debugger */ @@ -2969,11 +3072,8 @@ S_op_integerize(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_INTEGERIZE; - /* integerize op, unless it happens to be C<-foo>. - * XXX should pp_i_negate() do magic string negation instead? */ - if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) - && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST - && (cUNOPo->op_first->op_private & OPpCONST_BARE))) + /* integerize op. */ + if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) { dVAR; o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; @@ -3022,6 +3122,22 @@ S_fold_constants(pTHX_ register OP *o) 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; } @@ -3112,7 +3228,7 @@ S_fold_constants(pTHX_ register OP *o) 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; @@ -3683,9 +3799,6 @@ Perl_newOP(pTHX_ I32 type, I32 flags) 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)); @@ -4260,8 +4373,6 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); bool is_compiletime; bool has_code; - bool ext_eng; - regexp_engine *eng; PERL_ARGS_ASSERT_PMRUNTIME; @@ -4317,11 +4428,6 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) LINKLIST(expr); - /* are we using an external (non-perl) re engine? */ - - eng = current_re_engine(); - ext_eng = (eng && eng != &PL_core_reg_engine); - /* fix up DO blocks; treat each one as a separate little sub */ if (expr->op_type == OP_LIST) { @@ -4366,33 +4472,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); if (is_compiletime) { - U32 pm_flags = pm->op_pmflags & (RXf_PMf_COMPILETIME|PMf_HAS_CV); + U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + regexp_engine const *eng = current_re_engine(); if (o->op_flags & OPf_SPECIAL) - pm_flags |= RXf_SPLIT; + rx_flags |= RXf_SPLIT; - if (!has_code || ext_eng) { + if (!has_code || !eng->op_comp) { /* compile-time simple constant pattern */ - SV *pat; - - if (expr->op_type == OP_CONST) - pat = cSVOPx_sv(expr); - else { - /* concat any CONSTs */ - OP *kid = cLISTOPx(expr)->op_first; - pat = NULL; - for (; kid; kid = kid->op_sibling) { - if (kid->op_type != OP_CONST) - continue; - if (pat) - sv_catsv(pat, cSVOPx_sv(kid)); - else { - pat = cSVOPx_sv(kid); - SvREADONLY_off(pat); - } - } - assert(pat); - } if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { /* whoops! we guessed that a qr// had a code block, but we @@ -4401,23 +4488,19 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) * confident that nothing used that CV's pad while the * regex was parsed */ assert(AvFILLp(PL_comppad) == 0); /* just @_ */ + /* But we know that one op is using this CV's slab. */ + cv_forget_slab(PL_compcv); LEAVE_SCOPE(floor); pm->op_pmflags &= ~PMf_HAS_CV; } - if (DO_UTF8(pat)) { - assert (SvUTF8(pat)); - } else if (SvUTF8(pat)) { - /* Not doing UTF-8, despite what the SV says. Is this only if we're - trapped in use 'bytes'? */ - /* Make a copy of the octet sequence, but without the flag on, as - the compiler now honours the SvUTF8 flag on pat. */ - STRLEN len; - const char *const p = SvPV(pat, len); - pat = newSVpvn_flags(p, len, SVs_TEMP); - } - - PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); + PM_SETRE(pm, + eng->op_comp + ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + ); #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); #else @@ -4426,7 +4509,11 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) } else { /* compile-time pattern that includes literal code blocks */ - REGEXP* re = re_op_compile(NULL, 0, expr, pm_flags); + REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, + (pm->op_pmflags | + ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) + ); PM_SETRE(pm, re); if (pm->op_pmflags & PMf_HAS_CV) { CV *cv; @@ -4455,15 +4542,25 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) else { /* runtime pattern: build chain of regcomp etc ops */ bool reglist; + PADOFFSET cv_targ = 0; reglist = isreg && expr->op_type == OP_LIST; if (reglist) op_null(expr); - if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) - expr = newUNOP((!(PL_hints & HINT_RE_EVAL) - ? OP_REGCRESET - : OP_REGCMAYBE),0,expr); + if (has_code) { + pm->op_code_list = expr; + /* don't free op_code_list; its ops are embedded elsewhere too */ + pm->op_pmflags |= PMf_CODELIST_PRIVATE; + } + + /* the OP_REGCMAYBE is a placeholder in the non-threaded case + * to allow its op_next to be pointed past the regcomp and + * preceding stacking ops; + * OP_REGCRESET is there to reset taint before executing the + * stacking ops */ + if (pm->op_pmflags & PMf_KEEP || PL_tainting) + expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr); if (pm->op_pmflags & PMf_HAS_CV) { /* we have a runtime qr with literal code. This means @@ -4501,8 +4598,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) */ SvREFCNT_inc_simple_void(PL_compcv); - expr = list(force_list(newUNOP(OP_ENTERSUB, 0, - scalar(newANONATTRSUB(floor, NULL, NULL, expr))))); + /* these lines are just an unrolled newANONATTRSUB */ + expr = newSVOP(OP_ANONCODE, 0, + MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); + cv_targ = expr->op_targ; + expr = newUNOP(OP_REFGEN, 0, expr); + + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); } NewOp(1101, rcop, 1, LOGOP); @@ -4514,8 +4616,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) | (reglist ? OPf_STACKED : 0); rcop->op_private = 0; rcop->op_other = o; - if (reglist) - rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); + rcop->op_targ = cv_targ; /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1; @@ -4642,6 +4743,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 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) @@ -4826,7 +4928,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) OP *imop; OP *veop; #ifdef PERL_MAD - OP *pegop = newOP(OP_NULL,0); + OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL; #endif SV *use_version = NULL; @@ -4961,11 +5063,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_cop_seqmax++; #ifdef PERL_MAD - if (!PL_madskills) { - /* FIXME - don't allocate pegop if !PL_madskills */ - op_free(pegop); - return NULL; - } return pegop; #endif } @@ -5648,6 +5745,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || 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 { @@ -5805,6 +5904,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) || 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); @@ -6077,9 +6178,8 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, scalar(listop); o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { - op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); - return NULL; /* listop already freed by new_logop */ + return expr; /* listop already freed by new_logop */ } if (listop) ((LISTOP*)listop)->op_last->op_next = @@ -6242,7 +6342,9 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ loop->op_private = (U8)iterpflags; -#ifdef PL_OP_SLAB_ALLOC + if (loop->op_slabbed + && DIFF(loop, OpSLOT(loop)->opslot_next) + < SIZE_TO_PSIZE(sizeof(LOOP))) { LOOP *tmp; NewOp(1234,tmp,1,LOOP); @@ -6250,9 +6352,8 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } -#else - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); -#endif + else if (!loop->op_slabbed) + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); if (madsv) @@ -6740,13 +6841,15 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, U32 ps_utf8 = 0; register 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 then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a full GV and CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags - = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) + = ec ? GV_NOADD_NOINIT : + (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; @@ -6755,6 +6858,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, 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); @@ -6795,6 +6901,27 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SAVEFREEOP(attrs); } + if (ec) { + op_free(block); + if (name && block) { + const char *s = strrchr(name, ':'); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + const char not_safe[] = + "BEGIN not safe after errors--compilation aborted"; + if (PL_in_eval & EVAL_KEEPERR) + Perl_croak(aTHX_ not_safe); + else { + /* force display of errors found but not reported */ + sv_catpv(ERRSV, not_safe); + Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); + } + } + } + cv = PL_compcv; + goto done; + } + if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { @@ -6877,10 +7004,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } } if (const_sv) { - HV *stash; SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; @@ -6894,14 +7021,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv ); } - stash = - (CvGV(cv) && GvSTASH(CvGV(cv))) - ? GvSTASH(CvGV(cv)) - : CvSTASH(cv) - ? CvSTASH(cv) - : PL_curstash; - if (HvENAME_HEK(stash)) - mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */ if (PL_madskills) goto install_block; op_free(block); @@ -6919,6 +7038,8 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; AV *const temp_av = CvPADLIST(cv); CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t slabbed = CvSLABBED(cv); + OP * const cvstart = CvSTART(cv); assert(!CvWEAKOUTSIDE(cv)); assert(!CvCVGV_RC(cv)); @@ -6931,6 +7052,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvPADLIST(cv) = CvPADLIST(PL_compcv); CvOUTSIDE(PL_compcv) = temp_cv; 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); if (CvFILE(cv) && CvDYNFILE(cv)) { Safefree(CvFILE(cv)); @@ -6979,25 +7104,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } - if (PL_parser && PL_parser->error_count) { - op_free(block); - block = NULL; - if (name) { - const char *s = strrchr(name, ':'); - s = s ? s+1 : name; - if (strEQ(s, "BEGIN")) { - const char not_safe[] = - "BEGIN not safe after errors--compilation aborted"; - if (PL_in_eval & EVAL_KEEPERR) - Perl_croak(aTHX_ not_safe); - else { - /* force display of errors found but not reported */ - sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); - } - } - } - } install_block: if (!block) goto attrs; @@ -7018,13 +7124,19 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #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); + /* 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; CALL_PEEP(CvSTART(cv)); @@ -7081,6 +7193,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, 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; } @@ -7322,6 +7438,23 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, return cv; } +CV * +Perl_newSTUB(pTHX_ GV *gv, bool fake) +{ + register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + PERL_ARGS_ASSERT_NEWSTUB; + assert(!GvCVu(gv)); + GvCV_set(gv, cv); + GvCVGEN(gv) = 0; + if (!fake && HvENAME_HEK(GvSTASH(gv))) + mro_method_changed_in(GvSTASH(gv)); + CvGV_set(cv, gv); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + GvMULTI_on(gv); + return cv; +} + /* =for apidoc U||newXS @@ -7395,6 +7528,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) #else op_free(o); #endif + cv_forget_slab(cv); if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); @@ -7996,7 +8130,8 @@ Perl_ck_ftst(pTHX_ OP *o) 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 @@ -8168,7 +8303,6 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; - LINKLIST(kid); newop->op_next = newop; kid = newop; kid->op_sibling = sibl; @@ -8414,7 +8548,7 @@ OP * 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; @@ -8425,16 +8559,9 @@ Perl_ck_grep(pTHX_ OP *o) /* 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; @@ -8450,11 +8577,10 @@ Perl_ck_grep(pTHX_ OP *o) 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; @@ -8469,8 +8595,6 @@ Perl_ck_grep(pTHX_ OP *o) } 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); @@ -8584,7 +8708,8 @@ Perl_ck_listiob(pTHX_ OP *o) 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; @@ -8992,12 +9117,11 @@ Perl_ck_sort(pTHX_ OP *o) { 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); @@ -9006,52 +9130,24 @@ Perl_ck_sort(pTHX_ OP *o) 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; } @@ -9059,8 +9155,7 @@ Perl_ck_sort(pTHX_ OP *o) } /* provide list context for arguments */ - if (o->op_type == OP_SORT) - list(firstkid); + list(firstkid); return o; } @@ -9074,6 +9169,7 @@ S_simplify_sort(pTHX_ OP *o) int descending; GV *gv; const char *gvname; + bool have_scopeop; PERL_ARGS_ASSERT_SIMPLIFY_SORT; @@ -9082,20 +9178,50 @@ S_simplify_sort(pTHX_ OP *o) GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); kid = kUNOP->op_first; /* get past null */ - if (kid->op_type != OP_SCOPE) + if (!(have_scopeop = kid->op_type == OP_SCOPE) + && kid->op_type != OP_LEAVE) return; kid = kLISTOP->op_last; /* get past scope */ switch(kid->op_type) { case OP_NCMP: case OP_I_NCMP: case OP_SCMP: + if (!have_scopeop) goto padkids; break; default: return; } k = kid; /* remember this node*/ - if (kBINOP->op_first->op_type != OP_RV2SV) + if (kBINOP->op_first->op_type != OP_RV2SV + || kBINOP->op_last ->op_type != OP_RV2SV) + { + /* + Warn about my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ + + padkids: + if (!ckWARN(WARN_SYNTAX)) return; + kid = kBINOP->op_first; + do { + if (kid->op_type == OP_PADSV) { + 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), + "\"%s %s\" used in sort comparison", + SvPAD_STATE(name) ? "state" : "my", + SvPVX(name)); + } + } while ((kid = kid->op_sibling)); return; + } kid = kBINOP->op_first; /* get past cmp */ if (kUNOP->op_first->op_type != OP_GV) return; @@ -9112,8 +9238,7 @@ S_simplify_sort(pTHX_ OP *o) return; kid = k; /* back to cmp */ - if (kBINOP->op_last->op_type != OP_RV2SV) - return; + /* already checked above that it is rv2sv */ kid = kBINOP->op_last; /* down to 2nd arg */ if (kUNOP->op_first->op_type != OP_GV) return; @@ -9896,23 +10021,6 @@ Perl_ck_svconst(pTHX_ OP *o) } 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; @@ -9923,7 +10031,8 @@ Perl_ck_trunc(pTHX_ OP *o) 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; @@ -10168,12 +10277,14 @@ S_inplace_aassign(pTHX_ OP *o) { #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 @@ -10465,8 +10576,18 @@ Perl_rpeep(pTHX_ register OP *o) 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;