X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8fa6a40953ef88573ed3cbbb37666e7b72dec7dd..78a635de15dde640c98d94757206df013d18a651:/op.c diff --git a/op.c b/op.c index 40053e5..f807d33 100644 --- a/op.c +++ b/op.c @@ -102,131 +102,306 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" +#include "feature.h" +#include "regcomp.h" #define CALL_PEEP(o) PL_peepp(aTHX_ o) #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) { @@ -245,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 @@ -316,7 +440,7 @@ Perl_Slab_Free(pTHX_ void *op) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC const char* +STATIC SV* S_gv_ename(pTHX_ GV *gv) { SV* const tmpsv = sv_newmortal(); @@ -324,7 +448,7 @@ S_gv_ename(pTHX_ GV *gv) PERL_ARGS_ASSERT_GV_ENAME; gv_efullname3(tmpsv, gv, NULL); - return SvPV_nolen_const(tmpsv); + return tmpsv; } STATIC OP * @@ -338,30 +462,57 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments(pTHX_ OP *o, const char *name) +S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv), + SvUTF8(namesv) | flags); + return o; +} + +STATIC OP * +S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags); + return o; +} + +STATIC OP * +S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) { - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS; + PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV; - yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags); return o; } STATIC OP * -S_too_many_arguments(pTHX_ OP *o, const char *name) +S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) { - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS; + PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), + SvUTF8(namesv) | flags); return o; } STATIC void -S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) +S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { - PERL_ARGS_ASSERT_BAD_TYPE; + PERL_ARGS_ASSERT_BAD_TYPE_PV; + + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", + (int)n, name, t, OP_DESC(kid)), flags); +} - yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, OP_DESC(kid))); +STATIC void +S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid) +{ + PERL_ARGS_ASSERT_BAD_TYPE_SV; + + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); } STATIC void @@ -400,17 +551,18 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) if (len && !(is_our || isALPHA(name[1]) || - ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) || + ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ - if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { + if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, - PL_parser->in_my == KEY_state ? "state" : "my")); + yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, + PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } @@ -436,16 +588,49 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) return off; } +/* +=for apidoc alloccopstash + +Available only under threaded builds, this function allocates an entry in +C for the stash passed to it. + +=cut +*/ + +#ifdef USE_ITHREADS +PADOFFSET +Perl_alloccopstash(pTHX_ HV *hv) +{ + PADOFFSET off = 0, o = 1; + bool found_slot = FALSE; + + PERL_ARGS_ASSERT_ALLOCCOPSTASH; + + if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; + + for (; o < PL_stashpadmax; ++o) { + if (PL_stashpad[o] == hv) return PL_stashpadix = o; + if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) + found_slot = TRUE, off = o; + } + if (!found_slot) { + Renew(PL_stashpad, PL_stashpadmax + 10, HV *); + Zero(PL_stashpad + PL_stashpadmax, 10, HV *); + off = PL_stashpadmax; + PL_stashpadmax += 10; + } + + PL_stashpad[PL_stashpadix = off] = hv; + return off; +} +#endif + /* free the body of an op without examining its contents. * Always use this rather than FreeOp directly */ static void S_op_destroy(pTHX_ OP *o) { - if (o->op_latefree) { - o->op_latefreed = 1; - return; - } FreeOp(o); } @@ -463,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) { @@ -504,35 +689,24 @@ Perl_op_free(pTHX_ OP *o) 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) @@ -634,6 +808,7 @@ Perl_op_clear(pTHX_ OP *o) } #endif break; + case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: @@ -644,6 +819,7 @@ Perl_op_clear(pTHX_ OP *o) 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); @@ -676,6 +852,9 @@ Perl_op_clear(pTHX_ OP *o) case OP_MATCH: case OP_QR: clear_pmop: + 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; /* we use the same protection as the "SAFE" version of the PM_ macros @@ -712,7 +891,6 @@ S_cop_free(pTHX_ COP* cop) PERL_ARGS_ASSERT_COP_FREE; CopFILE_free(cop); - CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); cophh_free(CopHINTHASH_get(cop)); @@ -729,7 +907,7 @@ S_forget_pmop(pTHX_ PMOP *const o PERL_ARGS_ASSERT_FORGET_PMOP; - if (pmstash && !SvIS_FREED(pmstash)) { + if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); if (mg) { PMOP **const array = (PMOP**) mg->mg_ptr; @@ -836,7 +1014,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) case G_ARRAY: return list(o); case G_VOID: return scalarvoid(o); default: - Perl_croak(aTHX_ "panic: op_contextualize bad context"); + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); return o; } } @@ -864,7 +1043,7 @@ Perl_op_linklist(pTHX_ OP *o) /* establish postfix order */ first = cUNOPo->op_first; if (first) { - register OP *kid; + OP *kid; o->op_next = LINKLIST(first); kid = first; for (;;) { @@ -986,8 +1165,8 @@ Perl_scalarvoid(pTHX_ OP *o) { dVAR; OP *kid; + SV *useless_sv = NULL; const char* useless = NULL; - U32 useless_is_utf8 = 0; SV* sv; U8 want; @@ -1114,6 +1293,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: + case OP_RUNCV: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) /* Otherwise it's "Useless use of grep iterator" */ @@ -1164,14 +1344,6 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { - if (SvOK(sv)) { - SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ - "a constant (%"SVf")", sv)); - useless = SvPV_nolen(msv); - useless_is_utf8 = SvUTF8(msv); - } - else - useless = "a constant (undef)"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1193,7 +1365,24 @@ Perl_scalarvoid(pTHX_ OP *o) strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) useless = NULL; + else { + SV * const dsv = newSVpvs(""); + 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); + } + } + else if (SvOK(sv)) { + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); } + else + useless = "a constant (undef)"; } } op_null(o); /* don't execute or even remember it */ @@ -1317,10 +1506,18 @@ Perl_scalarvoid(pTHX_ OP *o) 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; } @@ -1467,7 +1664,7 @@ Perl_finalize_optree(pTHX_ OP* o) LEAVE; } -void +STATIC void S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; @@ -1613,9 +1810,10 @@ S_finalize_op(pTHX_ OP* o) key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { - Perl_croak(aTHX_ "No such class field \"%s\" " - "in variable %s of type %s", - key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); + Perl_croak(aTHX_ "No such class field \"%"SVf"\" " + "in variable %"SVf" of type %"HEKf, + SVfARG(*svp), SVfARG(lexname), + HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); } break; } @@ -1668,9 +1866,10 @@ S_finalize_op(pTHX_ OP* o) key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { - Perl_croak(aTHX_ "No such class field \"%s\" " - "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); + Perl_croak(aTHX_ "No such class field \"%"SVf"\" " + "in variable %"SVf" of type %"HEKf, + SVfARG(*svp), SVfARG(lexname), + HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); } } break; @@ -1729,9 +1928,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID ); + if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; + switch (o->op_type) { case OP_UNDEF: - localize = 0; PL_modcount++; return o; case OP_STUB: @@ -1755,14 +1955,13 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV)); PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { - /* Backward compatibility mode: */ + /* Potential lvalue context: */ o->op_private |= OPpENTERSUB_INARGS; break; } else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; - OP *okid; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -1775,33 +1974,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) while (kid->op_sibling) kid = kid->op_sibling; if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { - /* Indirect call */ - if (kid->op_type == OP_METHOD_NAMED - || kid->op_type == OP_METHOD) - { - UNOP *newop; - - NewOp(1101, newop, 1, UNOP); - newop->op_type = OP_RV2CV; - newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_first = NULL; - newop->op_next = (OP*)newop; - kid->op_sibling = (OP*)newop; - newop->op_private |= OPpLVAL_INTRO; - newop->op_private &= ~1; - break; - } - - if (kid->op_type != OP_RV2CV) - Perl_croak(aTHX_ - "panic: unexpected lvalue entersub " - "entry via type/targ %ld:%"UVuf, - (long)kid->op_type, (UV)kid->op_targ); - kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } - okid = kid; kid = kUNOP->op_first; if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) kid = kUNOP->op_first; @@ -1811,25 +1986,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { - /* Restore RV2CV to check lvalueness */ - restore_2cv: - if (kid->op_next && kid->op_next != kid) { /* Happens? */ - okid->op_next = kid->op_next; - kid->op_next = okid; - } - else - okid->op_next = NULL; - okid->op_type = OP_RV2CV; - okid->op_targ = 0; - okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; - okid->op_private |= OPpLVAL_INTRO; - okid->op_private &= ~1; break; } cv = GvCV(kGVOP_gv); if (!cv) - goto restore_2cv; + break; if (CvLVALUE(cv)) break; } @@ -2017,6 +2179,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (type != OP_LEAVESUBLV) goto nomod; break; /* op_lvalue()ing was handled by ck_return() */ + + case OP_COREARGS: + return o; } /* [20011101.069] File test operators interpret OPf_REF to mean that @@ -2054,11 +2219,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) STATIC bool S_scalar_mod_type(const OP *o, I32 type) { - assert(o || type != OP_SASSIGN); - switch (type) { + case OP_POS: case OP_SASSIGN: - if (o->op_type == OP_RV2GV) + if (o && o->op_type == OP_RV2GV) return FALSE; /* FALL THROUGH */ case OP_PREINC: @@ -2424,11 +2588,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); - } else if (type == OP_UNDEF -#ifdef PERL_MAD - || type == OP_STUB -#endif - ) { + return o; + } else if (type == OP_UNDEF || type == OP_STUB) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || @@ -2558,11 +2719,28 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) || rtype == OP_TRANSR ) ? (int)rtype : OP_MATCH]; - const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) + const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; + GV *gv; + SV * const name = + (ltype == OP_RV2AV || ltype == OP_RV2HV) + ? cUNOPx(left)->op_first->op_type == OP_GV + && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) + ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) + : NULL + : varname( + (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 + ); + if (name) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Applying %s to %"SVf" will act on scalar(%"SVf")", + desc, name, name); + else { + const char * const sample = (isary ? "@array" : "%hash"); - Perl_warner(aTHX_ packWARN(WARN_MISC), + Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); + } } if (rtype == OP_CONST && @@ -2609,7 +2787,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) } else return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, 0)); + pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0)); } OP * @@ -2665,6 +2843,18 @@ Perl_op_scope(pTHX_ OP *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) { @@ -2745,6 +2935,7 @@ Perl_newPROG(pTHX_ OP *o) if (PL_in_eval) { PERL_CONTEXT *cx; + I32 i; if (PL_eval_root) return; PL_eval_root = newUNOP(OP_LEAVEEVAL, @@ -2761,16 +2952,17 @@ 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); PL_eval_root->op_next = 0; + i = PL_savestack_ix; + SAVEFREEOP(o); + ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); - + LEAVE; + PL_savestack_ix = i; } else { if (o->op_type == OP_STUB) { @@ -2787,6 +2979,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 */ @@ -2900,11 +3093,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)]; @@ -2921,7 +3111,7 @@ static OP * 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; @@ -2950,9 +3140,27 @@ S_fold_constants(pTHX_ register OP *o) case OP_SCMP: case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (PL_hints & HINT_LOCALE) + 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 (PL_parser && PL_parser->error_count) @@ -3041,7 +3249,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; @@ -3053,7 +3261,7 @@ static OP * S_gen_constant_list(pTHX_ register OP *o) { dVAR; - register OP *curop; + OP *curop; const I32 oldtmps_floor = PL_tmps_floor; list(o); @@ -3091,6 +3299,7 @@ OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { dVAR; + if (type < 0) type = -type, flags |= OPf_SPECIAL; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); else @@ -3597,6 +3806,11 @@ Perl_newOP(pTHX_ I32 type, I32 flags) dVAR; OP *o; + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP @@ -3606,9 +3820,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)); @@ -3639,6 +3850,11 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) dVAR; UNOP *unop; + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP @@ -3747,10 +3963,10 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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; @@ -3951,9 +4167,6 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; - PerlMemShared_free(cPVOPo->op_pv); - cPVOPo->op_pv = NULL; - swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); @@ -3987,9 +4200,12 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) return o; } - tbl = (short*)cPVOPo->op_pv; + tbl = (short*)PerlMemShared_calloc( + (o->op_private & OPpTRANS_COMPLEMENT) && + !(o->op_private & OPpTRANS_DELETE) ? 258 : 256, + sizeof(short)); + cPVOPo->op_pv = (char*)tbl; if (complement) { - Zero(tbl, 256, short); for (i = 0; i < (I32)tlen; i++) tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { @@ -4102,10 +4318,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (PL_hints & HINT_LOCALE) { + if (IN_LOCALE_COMPILETIME) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) { + else if ((! (PL_hints & HINT_BYTES)) + /* Both UNI_8_BIT and locale :not_characters imply Unicode */ + && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) + { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -4158,25 +4377,29 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. + * + * When the pattern has been compiled within a new anon CV (for + * qr/(?{...})/ ), then floor indicates the savestack level just before + * the new sub was created */ OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) +Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) { dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; OP* repl = NULL; - bool reglist; + bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); + bool is_compiletime; + bool has_code; PERL_ARGS_ASSERT_PMRUNTIME; - if ( - o->op_type == OP_SUBST - || o->op_type == OP_TRANS || o->op_type == OP_TRANSR - ) { - /* last element in list is the replacement; pop it */ + /* for s/// and tr///, last element in list is the replacement; pop it */ + + if (is_trans || o->op_type == OP_SUBST) { OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; @@ -4186,60 +4409,224 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) cLISTOPx(expr)->op_last = kid; } - if (isreg && expr->op_type == OP_LIST && - cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) - { - /* convert single element list to element */ + /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ + + if (is_trans) { OP* const oe = expr; - expr = cLISTOPx(oe)->op_first->op_sibling; + assert(expr->op_type == OP_LIST); + assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); + assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); + expr = cLISTOPx(oe)->op_last; cLISTOPx(oe)->op_first->op_sibling = NULL; cLISTOPx(oe)->op_last = NULL; op_free(oe); - } - if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) { return pmtrans(o, expr, repl); } - reglist = isreg && expr->op_type == OP_LIST; - if (reglist) - op_null(expr); + /* find whether we have any runtime or code elements; + * at the same time, temporarily set the op_next of each DO block; + * then when we LINKLIST, this will cause the DO blocks to be excluded + * from the op_next chain (and from having LINKLIST recursively + * applied to them). We fix up the DOs specially later */ + + is_compiletime = 1; + has_code = 0; + if (expr->op_type == OP_LIST) { + OP *o; + for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { + has_code = 1; + assert(!o->op_next && o->op_sibling); + o->op_next = o->op_sibling; + } + else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) + is_compiletime = 0; + } + } + else if (expr->op_type != OP_CONST) + is_compiletime = 0; + + LINKLIST(expr); + + /* fix up DO blocks; treat each one as a separate little sub */ + + if (expr->op_type == OP_LIST) { + OP *o; + for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))) + continue; + o->op_next = NULL; /* undo temporary hack from above */ + scalar(o); + LINKLIST(o); + if (cLISTOPo->op_first->op_type == OP_LEAVE) { + LISTOP *leave = cLISTOPx(cLISTOPo->op_first); + /* skip ENTER */ + assert(leave->op_first->op_type == OP_ENTER); + assert(leave->op_first->op_sibling); + o->op_next = leave->op_first->op_sibling; + /* skip LEAVE */ + assert(leave->op_flags & OPf_KIDS); + assert(leave->op_last->op_next = (OP*)leave); + leave->op_next = NULL; /* stop on last op */ + op_null((OP*)leave); + } + else { + /* skip SCOPE */ + OP *scope = cLISTOPo->op_first; + assert(scope->op_type == OP_SCOPE); + assert(scope->op_flags & OPf_KIDS); + scope->op_next = NULL; /* stop on last op */ + op_null(scope); + } + /* have to peep the DOs individually as we've removed it from + * the op_next chain */ + CALL_PEEP(o); + if (is_compiletime) + /* runtime finalizes as part of finalizing whole tree */ + finalize_optree(o); + } + } PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; + assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); - if (expr->op_type == OP_CONST) { - SV *pat = ((SVOP*)expr)->op_sv; - U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + if (is_compiletime) { + 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; - - 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)); + rx_flags |= RXf_SPLIT; + + if (!has_code || !eng->op_comp) { + /* compile-time simple constant pattern */ + + if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { + /* whoops! we guessed that a qr// had a code block, but we + * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv + * that isn't required now. Note that we have to be pretty + * 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; + } + 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'); + op_getmad(expr,(OP*)pm,'e'); #else - op_free(expr); + op_free(expr); #endif + } + else { + /* compile-time pattern that includes literal code blocks */ + 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; + /* this QR op (and the anon sub we embed it in) is never + * actually executed. It's just a placeholder where we can + * squirrel away expr in op_code_list without the peephole + * optimiser etc processing it for a second time */ + OP *qr = newPMOP(OP_QR, 0); + ((PMOP*)qr)->op_code_list = expr; + + /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ + SvREFCNT_inc_simple_void(PL_compcv); + cv = newATTRSUB(floor, 0, NULL, NULL, qr); + ((struct regexp *)SvANY(re))->qr_anoncv = cv; + + /* attach the anon CV to the pad so that + * pad_fixup_inner_anons() can find it */ + (void)pad_add_anon(cv, o->op_type); + SvREFCNT_inc_simple_void(cv); + } + else { + pm->op_code_list = expr; + } + } } else { - if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) - expr = newUNOP((!(PL_hints & HINT_RE_EVAL) - ? OP_REGCRESET - : OP_REGCMAYBE),0,expr); + /* 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 (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 + * that the qr// has been wrapped in a new CV, which + * means that runtime consts, vars etc will have been compiled + * against a new pad. So... we need to execute those ops + * within the environment of the new CV. So wrap them in a call + * to a new anon sub. i.e. for + * + * qr/a$b(?{...})/, + * + * we build an anon sub that looks like + * + * sub { "a", $b, '(?{...})' } + * + * and call it, passing the returned list to regcomp. + * Or to put it another way, the list of ops that get executed + * are: + * + * normal PMf_HAS_CV + * ------ ------------------- + * pushmark (for regcomp) + * pushmark (for entersub) + * pushmark (for refgen) + * anoncode + * refgen + * entersub + * regcreset regcreset + * pushmark pushmark + * const("a") const("a") + * gvsv(b) gvsv(b) + * const("(?{...})") const("(?{...})") + * leavesub + * regcomp regcomp + */ + + SvREFCNT_inc_simple_void(PL_compcv); + /* 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); rcop->op_type = OP_REGCOMP; @@ -4248,16 +4635,15 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); - rcop->op_private = 1; + 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; /* establish postfix order */ - if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { + if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { LINKLIST(expr); rcop->op_next = expr; ((UNOP*)expr)->op_first->op_next = (OP*)rcop; @@ -4378,6 +4764,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) @@ -4475,9 +4862,13 @@ OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; + const bool utf8 = cBOOL(flags & SVf_UTF8); PVOP *pvop; + flags &= ~SVf_UTF8; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || type == OP_RUNCV || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); @@ -4486,6 +4877,7 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) pvop->op_pv = pv; pvop->op_next = (OP*)pvop; pvop->op_flags = (U8)flags; + pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) @@ -4508,10 +4900,10 @@ Perl_package(pTHX_ OP *o) PERL_ARGS_ASSERT_PACKAGE; - save_hptr(&PL_curstash); + SAVEGENERICSV(PL_curstash); save_item(PL_curstname); - PL_curstash = gv_stashsv(sv, GV_ADD); + PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD)); sv_setsv(PL_curstname, sv); @@ -4557,7 +4949,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; @@ -4641,22 +5033,29 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) newSTATEOP(0, NULL, imop) )); if (use_version) { - /* If we request a version >= 5.9.5, load feature.pm with the + /* Enable the * feature bundle that corresponds to the required version. */ use_version = sv_2mortal(new_version(use_version)); + S_enable_feature_bundle(aTHX_ use_version); - if (vcmp(use_version, - sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { - SV *const importsv = vnormal(use_version); - *SvPVX_mutable(importsv) = ':'; - ENTER_with_name("load_feature"); - Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE_with_name("load_feature"); - } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (vcmp(use_version, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { - PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints |= HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints |= HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints |= HINT_STRICT_VARS; + } + /* otherwise they are off */ + else { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints &= ~HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints &= ~HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints &= ~HINT_STRICT_VARS; } } @@ -4685,11 +5084,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 } @@ -4703,7 +5097,7 @@ Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS -(or 0 for no flags). ver, if specified, provides version semantics +(or 0 for no flags). ver, if specified and not NULL, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. They must be @@ -4712,6 +5106,8 @@ be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. Otherwise at least a single NULL pointer to designate the default import list is required. +The reference count for each specified C parameter is decremented. + =cut */ void @@ -4802,10 +5198,10 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + doop = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv)))))); + newGVOP(OP_GV, 0, gv))))); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); @@ -5170,7 +5566,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { dVAR; const U32 seq = intro_my(); - register COP *cop; + const U32 utf8 = flags & SVf_UTF8; + COP *cop; + + flags &= ~SVf_UTF8; NewOp(1101, cop, 1, COP); if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { @@ -5193,8 +5592,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); if (label) { - Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0); - + Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + PL_hints |= HINT_BLOCK_SCOPE; /* It seems that we need to defer freeing this pointer, as other parts of the grammar end up wanting to copy it after this op has been @@ -5206,8 +5605,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 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? */ @@ -5367,6 +5765,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 { @@ -5524,6 +5924,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); @@ -5654,6 +6056,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -5743,6 +6146,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -5794,9 +6198,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 = @@ -5959,7 +6362,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); @@ -5967,9 +6372,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) @@ -5983,7 +6387,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) Constructs, checks, and returns a loop-exiting op (such as C or C). I is the opcode. I