#include "keywords.h"
#include "feature.h"
#include "regcomp.h"
+#include "invlist_inline.h"
#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
-/* malloc a new op slab (suitable for attaching to PL_compcv) */
+/* requires double parens and aTHX_ */
+#define DEBUG_S_warn(args) \
+ DEBUG_S( \
+ PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
+ )
+
+
+/* malloc a new op slab (suitable for attaching to PL_compcv).
+ * sz is in units of pointers */
static OPSLAB *
-S_new_slab(pTHX_ size_t sz)
+S_new_slab(pTHX_ OPSLAB *head, size_t sz)
{
+ OPSLAB *slab;
+
+ /* opslot_offset is only U16 */
+ assert(sz < U16_MAX);
+
#ifdef PERL_DEBUG_READONLY_OPS
- OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+ 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",
perror("mmap failed");
abort();
}
- slab->opslab_size = (U16)sz;
#else
- OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+ slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
+ slab->opslab_size = (U16)sz;
+
#ifndef WIN32
/* The context is unused in non-Windows */
PERL_UNUSED_CONTEXT;
#endif
- slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
+ slab->opslab_head = head ? head : slab;
+ DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
+ (unsigned int)slab->opslab_size, (void*)slab,
+ (void*)(slab->opslab_head)));
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)) \
- )
/* Returns a sz-sized block of memory (suitable for holding an op) from
* a free slot in the chain of op slabs attached to PL_compcv.
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
- OPSLAB *slab;
+ OPSLAB *head_slab; /* first slab in the chain */
OPSLAB *slab2;
OPSLOT *slot;
OP *o;
- size_t opsz, space;
+ size_t opsz;
/* We only allocate ops from the slab during subroutine compilation.
We find the slab via PL_compcv, hence that must be non-NULL. It could
details. */
if (!CvSTART(PL_compcv)) {
CvSTART(PL_compcv) =
- (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
+ (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
CvSLABBED_on(PL_compcv);
- slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
+ head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
}
- else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
+ else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
opsz = SIZE_TO_PSIZE(sz);
sz = opsz + OPSLOT_HEADER_P;
/* The slabs maintain a free list of OPs. In particular, constant folding
will free up OPs, so it makes sense to re-use them where possible. A
freed up slot is used in preference to a new allocation. */
- if (slab->opslab_freed) {
- OP **too = &slab->opslab_freed;
+ if (head_slab->opslab_freed) {
+ OP **too = &head_slab->opslab_freed;
o = *too;
- DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
- while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+ DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)head_slab));
+
+ while (o && OpSLOT(o)->opslot_size < 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", (void*)o)); }
}
if (o) {
+ DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)head_slab));
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
}
}
-#define INIT_OPSLOT \
- slot->opslot_slab = slab; \
- slot->opslot_next = slab2->opslab_first; \
- slab2->opslab_first = slot; \
+#define INIT_OPSLOT(s) \
+ slot->opslot_offset = DIFF(slab2, slot) ; \
+ slot->opslot_size = s; \
+ slab2->opslab_free_space -= s; \
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) {
+ slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
+ if (slab2->opslab_free_space < 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) {
+ if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
slot = &slab2->opslab_slots;
- INIT_OPSLOT;
+ INIT_OPSLOT(slab2->opslab_free_space);
o->op_type = OP_FREED;
- o->op_next = slab->opslab_freed;
- slab->opslab_freed = o;
+ o->op_next = head_slab->opslab_freed;
+ head_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;
+ slab2 = S_new_slab(aTHX_ head_slab,
+ slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
+ ? PERL_MAX_SLAB_SIZE
+ : slab2->opslab_size * 2);
+ slab2->opslab_next = head_slab->opslab_next;
+ head_slab->opslab_next = slab2;
}
- assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
+ assert(slab2->opslab_size >= sz);
/* Create a new op slot */
- slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
+ slot = (OPSLOT *)
+ ((I32 **)&slab2->opslab_slots
+ + slab2->opslab_free_space - 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", (void*)o, (void*)slab));
+ INIT_OPSLOT(sz);
+ DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
+ (void*)o, (void*)slab2, (void*)head_slab));
gotit:
/* moresib == 0, op_sibling == 0 implies a solitary unattached op */
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", (void*)o, (void*)slab));
+ DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)slab));
OpslabREFCNT_dec_padok(slab);
}
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
- OPSLOT *slot;
- for (slot = slab2->opslab_first;
- slot->opslot_next;
- slot = slot->opslot_next) {
+ OPSLOT *slot = (OPSLOT*)
+ ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
+ OPSLOT *end = (OPSLOT*)
+ ((I32**)slab2 + slab2->opslab_size);
+ for (; slot < end;
+ slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
+ {
if (slot->opslot_op.op_type != OP_FREED
&& !(slot->opslot_op.op_savefree
#ifdef DEBUGGING
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)
{
{
SV * const namesv = cv_name((CV *)gv, NULL, 0);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
-
+
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));
}
&& isIDFIRST_utf8_safe((U8 *)name+1, name + len))
|| (name[1] == '_' && len > 2)))
{
+ const char * const type =
+ PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
+ PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
+
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& isASCII(name[1])
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
- /* diag_listed_as: Can't use global %s in "%s" */
- 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"));
+ /* diag_listed_as: Can't use global %s in %s */
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
+ name[0], toCTRL(name[1]),
+ (int)(len - 2), name + 2,
+ type));
} else {
- 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);
+ yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
+ (int) len, name,
+ type), flags & SVf_UTF8);
}
}
/** Bug #15654
Even if op_clear does a pad_free for the target of the op,
pad_free doesn't actually remove the sv that exists in the pad;
- instead it lives on. This results in that it could be reused as
+ instead it lives on. This results in that it could be reused as
a target later on when the pad was reallocated.
**/
if(o->op_targ) {
}
}
}
- if (PL_curpm == o)
+ if (PL_curpm == o)
PL_curpm = NULL;
}
&& (SvPOK(sv) || SvIOK(sv))
&& (!SvGMAGICAL(sv))
) {
+ if (argop->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(argop);
argp++->p = sv;
utf8 |= cBOOL(SvUTF8(sv));
nconst++;
sv_utf8_upgrade_nomg(sv);
argp->p = SvPV_nomg(sv, argp->len);
total_len += argp->len;
-
+
/* see if any strings would grow if converted to utf8 */
if (!utf8) {
variant += variant_under_utf8_count((U8 *) argp->p,
lastkidop = pmop;
}
- /* Optimise
+ /* Optimise
* target = A.B.C...
* target .= A.B.C...
*/
/* The listop in rops might have a pushmark at the beginning,
which will mess up list assignment. */
LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
- if (rops->op_type == OP_LIST &&
+ if (rops->op_type == OP_LIST &&
lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
{
OP * const pushmark = lrops->op_first;
dVAR;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
- o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
+ o = op_prepend_elem(OP_LINESEQ,
+ newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
OpTYPE_set(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
+void
+Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
+{
+ const char indent[] = " ";
+
+ UV len = _invlist_len(invlist);
+ UV * array = invlist_array(invlist);
+ UV i;
+
+ PERL_ARGS_ASSERT_INVMAP_DUMP;
+
+ for (i = 0; i < len; i++) {
+ UV start = array[i];
+ UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
+
+ PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
+ if (end == IV_MAX) {
+ PerlIO_printf(Perl_debug_log, " .. INFTY");
+ }
+ else if (end != start) {
+ PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+
+ PerlIO_printf(Perl_debug_log, "\t");
+
+ if (map[i] == TR_UNLISTED) {
+ PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
+ }
+ else if (map[i] == TR_SPECIAL_HANDLING) {
+ PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
+ }
+ }
+}
+
/* Helper function for S_pmtrans(): comparison function to sort an array
* of codepoint range pairs. Sorts by start point, or if equal, by end
* point */
while (t < tend) {
cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
- /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
- if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
+ /* the toker converts X-Y into (X, RANGE_INDICATOR, Y) */
+ if (t < tend && *t == RANGE_INDICATOR) {
t++;
cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
/* Create a utf8 string containing the complement of the
* codepoint ranges. For example if cp[] contains [A,B], [C,D],
* then transv will contain the equivalent of:
- * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
- * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
- * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
- * A range of a single char skips the ILLEGAL_UTF8_BYTE and
+ * join '', map chr, 0, RANGE_INDICATOR, A - 1,
+ * B + 1, RANGE_INDICATOR, C - 1,
+ * D + 1, RANGE_INDICATOR, 0x7fffffff;
+ * A range of a single char skips the RANGE_INDICATOR and
* end cp.
*/
for (j = 0; j < i; j++) {
t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
if (diff > 1) {
- U8 range_mark = ILLEGAL_UTF8_BYTE;
+ U8 range_mark = RANGE_INDICATOR;
t = uvchr_to_utf8(tmpbuf, val - 1);
sv_catpvn(transv, (char *)&range_mark, 1);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
{
- U8 range_mark = ILLEGAL_UTF8_BYTE;
+ U8 range_mark = RANGE_INDICATOR;
sv_catpvn(transv, (char *)&range_mark, 1);
}
t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
if (tfirst > tlast) {
tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
- if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
+ if (t < tend && *t == RANGE_INDICATOR) { /* illegal utf8 val indicates range */
t++;
tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
if (r < rend) {
rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
- if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
+ if (r < rend && *r == RANGE_INDICATOR) { /* illegal utf8 val indicates range */
r++;
rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
goto warnins;
}
- /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
- * table. Entries with the value -1 indicate chars not to be
- * translated, while -2 indicates a search char without a
- * corresponding replacement char under /d.
- *
- * Normally, the table has 256 slots. However, in the presence of
- * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
- * added, and if there are enough replacement chars to start pairing
- * with the \x{100},... search chars, then a larger (> 256) table
- * is allocated.
- *
- * In addition, regardless of whether under /c, an extra slot at the
- * end is used to store the final repeating char, or -3 under an empty
- * replacement list, or -2 under /d; which makes the runtime code
- * easier.
- *
- * The toker will have already expanded char ranges in t and r.
- */
+ /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
+ * table. Entries with the value TR_UNMAPPED indicate chars not to be
+ * translated, while TR_DELETE indicates a search char without a
+ * corresponding replacement char under /d.
+ *
+ * Normally, the table has 256 slots. However, in the presence of
+ * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
+ * added, and if there are enough replacement chars to start pairing
+ * with the \x{100},... search chars, then a larger (> 256) table
+ * is allocated.
+ *
+ * In addition, regardless of whether under /c, an extra slot at the
+ * end is used to store the final repeating char, or TR_R_EMPTY under an
+ * empty replacement list, or TR_DELETE under /d; which makes the
+ * runtime code easier.
+ *
+ * The toker will have already expanded char ranges in t and r.
+ */
- /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
- * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
- * The OPtrans_map struct already contains one slot; hence the -1.
- */
- struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
- tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
- tbl->size = 256;
- cPVOPo->op_pv = (char*)tbl;
+ /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
+ * plus final slot for repeat/TR_DELETE/TR_R_EMPTY. Later we realloc if
+ * excess > * 0. The OPtrans_map struct already contains one slot;
+ * hence the -1.
+ */
+ struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
+ tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
+ tbl->size = 256;
+ cPVOPo->op_pv = (char*)tbl;
- if (complement) {
- Size_t excess;
+ if (complement) {
+ Size_t excess;
- /* in this branch, j is a count of 'consumed' (i.e. paired off
- * with a search char) replacement chars (so j <= rlen always)
- */
- for (i = 0; i < tlen; i++)
- tbl->map[t[i]] = -1;
-
- for (i = 0, j = 0; i < 256; i++) {
- if (!tbl->map[i]) {
- if (j == rlen) {
- if (del)
- tbl->map[i] = -2;
- else if (rlen)
- tbl->map[i] = r[j-1];
- else
- tbl->map[i] = (short)i;
- }
- else {
- tbl->map[i] = r[j++];
- }
- if ( tbl->map[i] >= 0
- && UVCHR_IS_INVARIANT((UV)i)
- && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
- )
- grows = TRUE;
- }
- }
+ /* in this branch, j is a count of 'consumed' (i.e. paired off
+ * with a search char) replacement chars (so j <= rlen always)
+ */
+ for (i = 0; i < tlen; i++)
+ tbl->map[t[i]] = (short) TR_UNMAPPED;
+
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl->map[i]) {
+ if (j == rlen) {
+ if (del)
+ tbl->map[i] = (short) TR_DELETE;
+ else if (rlen)
+ tbl->map[i] = r[j-1];
+ else
+ tbl->map[i] = (short)i;
+ }
+ else {
+ tbl->map[i] = r[j++];
+ }
+ if ( tbl->map[i] >= 0
+ && UVCHR_IS_INVARIANT((UV)i)
+ && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
+ )
+ grows = TRUE;
+ }
+ }
- ASSUME(j <= rlen);
- excess = rlen - j;
+ ASSUME(j <= rlen);
+ excess = rlen - j;
- if (excess) {
- /* More replacement chars than search chars:
- * store excess replacement chars at end of main table.
- */
+ if (excess) {
+ /* More replacement chars than search chars:
+ * store excess replacement chars at end of main table.
+ */
- struct_size += excess;
- tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
- struct_size + excess * sizeof(short));
- tbl->size += excess;
- cPVOPo->op_pv = (char*)tbl;
+ struct_size += excess * sizeof(short);
+ tbl = (OPtrans_map*)PerlMemShared_realloc(tbl, struct_size);
+ tbl->size += excess;
+ cPVOPo->op_pv = (char*)tbl;
- for (i = 0; i < excess; i++)
- tbl->map[i + 256] = r[j+i];
+ for (i = 0; i < excess; i++)
+ tbl->map[i + 256] = r[j+i];
+ }
+ else {
+ /* no more replacement chars than search chars */
+ if (!rlen && !del && !squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
+
+ tbl->map[tbl->size] = del
+ ? (short) TR_DELETE
+ : rlen
+ ? r[rlen - 1]
+ : (short) TR_R_EMPTY;
}
else {
- /* no more replacement chars than search chars */
- if (!rlen && !del && !squash)
+ if (!rlen && !del) {
+ r = t; rlen = tlen;
+ if (!squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
+ else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
o->op_private |= OPpTRANS_IDENTICAL;
- }
-
- tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
- }
- else {
- if (!rlen && !del) {
- r = t; rlen = tlen;
- if (!squash)
- o->op_private |= OPpTRANS_IDENTICAL;
- }
- else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
- o->op_private |= OPpTRANS_IDENTICAL;
- }
+ }
- for (i = 0; i < 256; i++)
- tbl->map[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
- if (del) {
- if (tbl->map[t[i]] == -1)
- tbl->map[t[i]] = -2;
- continue;
- }
- --j;
- }
- if (tbl->map[t[i]] == -1) {
- if ( UVCHR_IS_INVARIANT(t[i])
- && ! UVCHR_IS_INVARIANT(r[j]))
- grows = TRUE;
- tbl->map[t[i]] = r[j];
- }
- }
- tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
- }
+ for (i = 0; i < 256; i++)
+ tbl->map[i] = (short) TR_UNMAPPED;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (del) {
+ if (tbl->map[t[i]] == (short) TR_UNMAPPED)
+ tbl->map[t[i]] = (short) TR_DELETE;
+ continue;
+ }
+ --j;
+ }
+ if (tbl->map[t[i]] == (short) TR_UNMAPPED) {
+ if ( UVCHR_IS_INVARIANT(t[i])
+ && ! UVCHR_IS_INVARIANT(r[j]))
+ grows = TRUE;
+ tbl->map[t[i]] = r[j];
+ }
+ }
+ tbl->map[tbl->size] = del
+ ? (short) TR_UNMAPPED
+ : rlen
+ ? (short) TR_UNMAPPED
+ : (short) TR_R_EMPTY;
+ }
/* both non-utf8 and utf8 code paths end up here */
warnins:
if(del && rlen == tlen) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
}
*
* Flags currently has 2 bits of meaning:
* 1: isreg indicates that the pattern is part of a regex construct, eg
- * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
- * 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/).
+ * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
+ * 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/).
* 2: The pattern is for a split.
*
* 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
+ *
+ * tr/// is also handled.
*/
OP *
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
loop->op_private = (U8)iterpflags;
+
+ /* upgrade loop from a LISTOP to a LOOPOP;
+ * keep it in-place if there's space */
if (loop->op_slabbed
- && DIFF(loop, OpSLOT(loop)->opslot_next)
- < SIZE_TO_PSIZE(sizeof(LOOP)))
+ && OpSLOT(loop)->opslot_size
+ < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
{
+ /* no space; allocate new op */
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
}
else if (!loop->op_slabbed)
{
+ /* loop was malloc()ed */
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
OpLASTSIB_set(loop->op_last, (OP*)loop);
}
SvPV_nolen_const(((SVOP*)label)->op_sv)));
}
}
-
+
/* If we have already created an op, we do not need the label. */
if (o)
op_free(label);
- a filetest operator, with the exception of -s -M -A -C
- defined(), exists() or eof()
- /$re/ or $foo =~ /$re/
-
+
[*] possibly surprising
*/
STATIC bool
case OP_SEQ: case OP_SNE: case OP_SLT:
case OP_SGT: case OP_SLE: case OP_SGE:
-
+
case OP_SMARTMATCH:
-
+
case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
case OP_FTTEXT: case OP_FTBINARY:
-
+
case OP_DEFINED: case OP_EXISTS:
case OP_MATCH: case OP_EOF:
if (o->op_private & OPpTRUEBOOL)
return TRUE;
return FALSE;
-
+
case OP_CONST:
/* Detect comparisons that have been optimized away */
if (cSVOPo->op_sv == &PL_sv_yes
|| cSVOPo->op_sv == &PL_sv_no)
-
+
return TRUE;
else
return FALSE;
newDEFSVOP(),
scalar(ref_array_or_hash(cond)));
}
-
+
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
the package sub. So check PadnameOUTER(name) too.
*/
- if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
assert(!CvWEAKOUTSIDE(compcv));
SvREFCNT_dec(CvOUTSIDE(compcv));
CvWEAKOUTSIDE_on(compcv);
cv = NULL;
}
}
-
+
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
{
SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
- OP * anoncode =
+ OP * anoncode =
newSVOP(OP_ANONCODE, 0,
cv);
if (CvANONCONST(cv))
if ((PL_hints & HINT_LOCALIZE_HH) != 0
&& !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
- OP *hhop = newSVOP(OP_HINTSEVAL, 0,
- MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
+ HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
+ OP *hhop;
+ STOREFEATUREBITSHH(hh);
+ hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
/* append hhop to only child */
op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
PL_op_desc[type]);
if (kid->op_type == OP_CONST
- && ( !SvROK(cSVOPx_sv(kid))
+ && ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
bad_type_pv(numargs, "array", o, kid);
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
OP *second = OpSIBLING(first);
-
+
/* Implicitly take a reference to an array or hash */
/* remove the original two siblings, then add back the
second = ref_array_or_hash(second);
op_sibling_splice(o, NULL, 0, second);
op_sibling_splice(o, NULL, 0, first);
-
+
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
OpTYPE_set(first, OP_QR);
OpTYPE_set(second, OP_QR);
}
}
-
+
return o;
}
HEK *hek;
if (was_readonly) {
- SvREADONLY_off(sv);
- }
+ SvREADONLY_off(sv);
+ }
+
if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
s = SvPVX(sv);
}
return ck_fun(o);
}
-
+
OP *
Perl_ck_join(pTHX_ OP *o)
{
yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
}
-
+
op_free(entersubop);
switch(cvflags >> 16) {
case 'F': return newSVOP(OP_CONST, 0,
parent = aop;
aop = cUNOPx(aop)->op_first;
}
-
+
first = prev = aop;
aop = OpSIBLING(aop);
/* find last sibling */
if (cvflags == (OP_ENTEREVAL | (1<<16)))
flags |= OPpEVAL_BYTES <<8;
-
+
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
-/*
+/*
---------------------------------------------------------
-
+
Common vars in list assignment
There now follows some enums and static functions for detecting
----
First some random observations:
-
+
* If a lexical var is an alias of something else, e.g.
for my $x ($lex, $pkg, $a[0]) {...}
then the act of aliasing will increase the reference count of the SV
-
+
* If a package var is an alias of something else, it may still have a
reference count of 1, depending on how the alias was created, e.g.
in *a = *b, $a may have a refcount of 1 since the GP is shared
with a single GvSV pointer to the SV. So If it's an alias of another
package var, then RC may be 1; if it's an alias of another scalar, e.g.
a lexical var or an array element, then it will have RC > 1.
-
+
* There are many ways to create a package alias; ultimately, XS code
may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
run-time tracing mechanisms are unlikely to be able to catch all cases.
-
+
* When the LHS is all my declarations, the same vars can't appear directly
on the RHS, but they can indirectly via closures, aliasing and lvalue
subs. But those techniques all involve an increase in the lexical
scalar's ref count.
-
+
* When the LHS is all lexical vars (but not necessarily my declarations),
it is possible for the same lexicals to appear directly on the RHS, and
without an increased ref count, since the stack isn't refcounted.
This case can be detected at compile time by scanning for common lex
vars with PL_generation.
-
+
* lvalue subs defeat common var detection, but they do at least
return vars with a temporary ref count increment. Also, you can't
tell at compile time whether a sub call is lvalue.
-
-
+
+
So...
-
+
A: There are a few circumstances where there definitely can't be any
commonality:
-
+
LHS empty: () = (...);
RHS empty: (....) = ();
RHS contains only constants or other 'can't possibly be shared'
RHS contains a single element with no aggregate on LHS: e.g.
($a,$b,$c) = ($x); again, once $a has been modified, its value
won't be used again.
-
+
B: If LHS are all 'my' lexical var declarations (or safe ops, which
we can ignore):
-
+
my ($a, $b, @c) = ...;
-
+
Due to closure and goto tricks, these vars may already have content.
For the same reason, an element on the RHS may be a lexical or package
alias of one of the vars on the left, or share common elements, for
example:
-
+
my ($x,$y) = f(); # $x and $y on both sides
sub f : lvalue { ($x,$y) = (1,2); $y, $x }
-
+
and
-
+
my $ra = f();
my @a = @$ra; # elements of @a on both sides
sub f { @a = 1..4; \@a }
-
-
+
+
First, just consider scalar vars on LHS:
-
+
RHS is safe only if (A), or in addition,
* contains only lexical *scalar* vars, where neither side's
- lexicals have been flagged as aliases
-
+ lexicals have been flagged as aliases
+
If RHS is not safe, then it's always legal to check LHS vars for
RC==1, since the only RHS aliases will always be associated
with an RC bump.
-
+
Note that in particular, RHS is not safe if:
-
+
* it contains package scalar vars; e.g.:
-
+
f();
my ($x, $y) = (2, $x_alias);
sub f { $x = 1; *x_alias = \$x; }
-
+
* It contains other general elements, such as flattened or
* spliced or single array or hash elements, e.g.
-
+
f();
- my ($x,$y) = @a; # or $a[0] or @a{@b} etc
-
+ my ($x,$y) = @a; # or $a[0] or @a{@b} etc
+
sub f {
($x, $y) = (1,2);
use feature 'refaliasing';
\($a[0], $a[1]) = \($y,$x);
}
-
+
It doesn't matter if the array/hash is lexical or package.
-
+
* it contains a function call that happens to be an lvalue
sub which returns one or more of the above, e.g.
-
+
f();
my ($x,$y) = f();
-
+
sub f : lvalue {
($x, $y) = (1,2);
*x1 = \$x;
$y, $x1;
}
-
+
(so a sub call on the RHS should be treated the same
as having a package var on the RHS).
-
+
* any other "dangerous" thing, such an op or built-in that
returns one of the above, e.g. pp_preinc
-
-
+
+
If RHS is not safe, what we can do however is at compile time flag
that the LHS are all my declarations, and at run time check whether
all the LHS have RC == 1, and if so skip the full scan.
-
+
Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
-
+
Here the issue is whether there can be elements of @a on the RHS
which will get prematurely freed when @a is cleared prior to
assignment. This is only a problem if the aliasing mechanism
is one which doesn't increase the refcount - only if RC == 1
will the RHS element be prematurely freed.
-
+
Because the array/hash is being INTROed, it or its elements
can't directly appear on the RHS:
-
+
my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
-
+
but can indirectly, e.g.:
-
+
my $r = f();
my (@a) = @$r;
sub f { @a = 1..3; \@a }
-
+
So if the RHS isn't safe as defined by (A), we must always
mortalise and bump the ref count of any remaining RHS elements
when assigning to a non-empty LHS aggregate.
-
+
Lexical scalars on the RHS aren't safe if they've been involved in
aliasing, e.g.
-
+
use feature 'refaliasing';
-
+
f();
\(my $lex) = \$pkg;
my @a = ($lex,3); # equivalent to ($a[0],3)
-
+
sub f {
@a = (1,2);
\$pkg = \$a[0];
}
-
+
Similarly with lexical arrays and hashes on the RHS:
-
+
f();
my @b;
my @a = (@b);
-
+
sub f {
@a = (1,2);
\$b[0] = \$a[1];
\$b[1] = \$a[0];
}
-
-
-
+
+
+
C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
my $a; ($a, my $b) = (....);
-
+
The difference between (B) and (C) is that it is now physically
possible for the LHS vars to appear on the RHS too, where they
are not reference counted; but in this case, the compile-time
PL_generation sweep will detect such common vars.
-
+
So the rules for (C) differ from (B) in that if common vars are
detected, the runtime "test RC==1" optimisation can no longer be used,
and a full mark and sweep is required
-
+
D: As (C), but in addition the LHS may contain package vars.
-
+
Since package vars can be aliased without a corresponding refcount
increase, all bets are off. It's only safe if (A). E.g.
-
+
my ($x, $y) = (1,2);
-
+
for $x_alias ($x) {
($x_alias, $y) = (3, $x); # whoops
}
-
+
Ditto for LHS aggregate package vars.
-
+
E: Any other dangerous ops on LHS, e.g.
(f(), $a[0], @$r) = (...);
-
+
this is similar to (E) in that all bets are off. In addition, it's
impossible to determine at compile time whether the LHS
contains a scalar or an aggregate, e.g.
-
+
sub f : lvalue { @a }
(f()) = 1..3;
this optimisation if the first NEXTSTATE has a label. */
if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
OP *nextop = o->op_next;
- while (nextop && nextop->op_type == OP_NULL)
- nextop = nextop->op_next;
+ while (nextop) {
+ switch (nextop->op_type) {
+ case OP_NULL:
+ case OP_SCALAR:
+ case OP_LINESEQ:
+ case OP_SCOPE:
+ nextop = nextop->op_next;
+ continue;
+ }
+ break;
+ }
if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
op_null(o);
}
break;
-
+
case OP_NOT:
break;
DEFER(cLOGOP->op_other);
o->op_opt = 1;
break;
-
+
case OP_GREPWHILE:
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
iter = enter->op_next;
if (!iter || iter->op_type != OP_ITER)
break;
-
+
expushmark = enter->op_first;
if (!expushmark || expushmark->op_type != OP_NULL
|| expushmark->op_targ != OP_PUSHMARK)
break;
case OP_CUSTOM: {
- Perl_cpeep_t cpeep =
+ Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
if (cpeep)
cpeep(aTHX_ o, oldop);
break;
}
-
+
}
/* did we just null the current op? If so, re-process it to handle
* eliding "empty" ops from the chain */
/*
=head1 Custom Operators
-=for apidoc custom_op_xop
+=for apidoc Perl_custom_op_xop
Return the XOP structure for a given custom op. This macro should be
considered internal to C<OP_NAME> and the other access macros: use them instead.
This macro does call a function. Prior
https://perl5.git.perl.org / perl5.git / blobdiff