/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ const char *const name)
+Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
dVAR;
PADOFFSET off;
PERL_ARGS_ASSERT_ALLOCMY;
+ if (flags)
+ Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
+ /* Until we're using the length for real, cross check that we're being
+ told the truth. */
+ assert(strlen(name) == len);
+
/* complain about "my $<special_var>" etc etc */
- if (*name &&
+ if (len &&
!(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (*name == '$' || name[2]))))
+ (name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
if (!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]), name + 2,
+ 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\"",name,
+ yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
/* check for duplicate declaration */
- pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
+ pad_check_dup(name, len, is_our ? pad_add_OUR : 0,
+ (PL_curstash ? PL_curstash : PL_defstash));
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name,
+ off = pad_add_name(name, len,
+ PL_parser->in_my == KEY_state ? pad_add_STATE : 0,
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
- ),
- 0, /* not fake */
- PL_parser->in_my == KEY_state
+ )
);
/* anon sub prototypes contains state vars should always be cloned,
* otherwise the state var would be shared between anon subs */
&& PL_curpad
#endif
? cGVOPo_gv : NULL;
- SvREFCNT_inc_simple_void(gv);
+ /* It's possible during global destruction that the GV is freed
+ before the optree. Whilst the SvREFCNT_inc is happy to bump from
+ 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
+ will trigger an assertion failure, because the entry to sv_clear
+ checks that the scalar is not already freed. A check of for
+ !SvIS_FREED(gv) turns out to be invalid, because during global
+ destruction the reference count can be forced down to zero
+ (with SVf_BREAK set). In which case raising to 1 and then
+ dropping to 0 triggers cleanup before it should happen. I
+ *think* that this might actually be a general, systematic,
+ weakness of the whole idea of SVf_BREAK, in that code *is*
+ allowed to raise and lower references during global destruction,
+ so any *valid* code that happens to do this during global
+ destruction might well trigger premature cleanup. */
+ bool still_valid = gv && SvREFCNT(gv);
+
+ if (still_valid)
+ SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
/* No GvIN_PAD_off(cGVOPo_gv) here, because other references
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#endif
- if (gv) {
+ if (still_valid) {
int try_downgrade = SvREFCNT(gv) == 2;
SvREFCNT_dec(gv);
if (try_downgrade)
if (PL_madskills) {
if (strEQ(name, "import")) {
PL_formfeed = MUTABLE_SV(cv);
- Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+ Perl_warner(aTHX_ packWARN(WARN_VOID), UVxf"\n", (UV)cv);
}
}
GvCVGEN(gv) = 0;
return (OP*)unop;
}
+/* Checks if o acts as an in-place operator on an array. oright points to the
+ * beginning of the right-hand side. Returns the left-hand side of the
+ * assignment if o acts in-place, or NULL otherwise. */
+
+OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+ OP *o2;
+ OP *oleft = NULL;
+
+ PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+ if (!oright ||
+ (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+ || oright->op_next != o
+ || (oright->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+
+ /* o2 follows the chain of op_nexts through the LHS of the
+ * assign (if any) to the aassign op itself */
+ o2 = o->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ o2 = o2->op_next;
+ if (o2 && o2->op_type == OP_GV)
+ o2 = o2->op_next;
+ if (!o2
+ || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+ || (o2->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+ oleft = o2;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_AASSIGN
+ || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ return NULL;
+
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ if (o2->op_sibling != o)
+ return NULL;
+
+ /* check the array is the same on both sides */
+ if (oleft->op_type == OP_RV2AV) {
+ if (oright->op_type != OP_RV2AV
+ || !cUNOPx(oright)->op_first
+ || cUNOPx(oright)->op_first->op_type != OP_GV
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ return NULL;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ return NULL;
+
+ return oleft;
+}
+
/* 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
* peep() is called */
oright = cUNOPx(oright)->op_sibling;
}
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- break;
-
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
- )
- break;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- /* check that the sort is the first arg on RHS of assign */
-
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- if (o2->op_sibling != o)
- break;
-
- /* check the array is the same on both sides */
- if (oleft->op_type == OP_RV2AV) {
- if (oright->op_type != OP_RV2AV
- || !cUNOPx(oright)->op_first
- || cUNOPx(oright)->op_first->op_type != OP_GV
- || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
- cGVOPx_gv(cUNOPx(oright)->op_first)
- )
- break;
- }
- else if (oright->op_type != OP_PADAV
- || oright->op_targ != oleft->op_targ
- )
+ oleft = is_inplace_av(o, oright);
+ if (!oleft)
break;
/* transfer MODishness etc from LHS arg to RHS arg */
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
+ OP *oleft, *oright;
LISTOP *enter, *exlist;
+ /* @a = reverse @a */
+ if ((oright = cLISTOPo->op_first)
+ && (oright->op_type == OP_PUSHMARK)
+ && (oright = oright->op_sibling)
+ && (oleft = is_inplace_av(o, oright))) {
+ OP *o2;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+ o->op_private |= OPpREVERSE_INPLACE;
+
+ /* excise push->gv->rv2av->null->aassign */
+ o2 = o->op_next->op_next;
+ op_null(o2); /* PUSHMARK */
+ o2 = o2->op_next;
+ if (o2->op_type == OP_GV) {
+ op_null(o2); /* GV */
+ o2 = o2->op_next;
+ }
+ op_null(o2); /* RV2AV or PADAV */
+ o2 = o2->op_next->op_next;
+ op_null(o2); /* AASSIGN */
+
+ o->op_next = o2->op_next;
+ break;
+ }
+
enter = (LISTOP *) o->op_next;
if (!enter)
break;
projects / p5sagit/p5-mst-13.2.git / blobdiff