diff options
| -rw-r--r-- | ext/B/t/concise-xs.t | 2 | ||||
| -rw-r--r-- | gv.c | 5 | ||||
| -rw-r--r-- | gv.h | 1 | ||||
| -rw-r--r-- | op.c | 58 | ||||
| -rw-r--r-- | op.h | 9 | ||||
| -rw-r--r-- | pp.c | 18 | ||||
| -rw-r--r-- | pp_hot.c | 54 | ||||
| -rw-r--r-- | sv.c | 5 |
8 files changed, 147 insertions, 5 deletions
diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index 0ac1aea172..b2b840bf39 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -95,7 +95,7 @@ use Carp; use Test::More tests => ( 1 * !!$Config::Config{useithreads} + 3 * ($] > 5.009) + 14 * ($] >= 5.009003) - + 777 ); + + 780 ); require_ok("B::Concise"); @@ -742,7 +742,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, register const char *namend; HV *stash = 0; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); - const I32 add = flags & ~SVf_UTF8 & ~ GV_NOADD_NOINIT; + const I32 no_expand = flags & GV_NOEXPAND; + const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND; PERL_UNUSED_ARG(full_len); @@ -909,6 +910,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return gv; } else if (no_init) { return gv; + } else if (no_expand && SvROK(gv)) { + return gv; } /* Adding a new symbol */ @@ -166,6 +166,7 @@ Return the SV from the GV. table into full PVGVs with attached constant subroutines. */ #define GV_NOADD_NOINIT 0x20 /* Don't add the symbol if it's not there. Don't init it if it is there but ! PVGV */ +#define GV_NOEXPAND 0x40 /* Don't expand SvOK() entries to PVGV */ /* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range. @@ -1050,6 +1050,10 @@ Perl_mod(pTHX_ OP *o, I32 type) if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ + /* The default is to set op_private to the number of children, + which for a UNOP such as RV2CV is always 1. And w're using + the bit for a flag in RV2CV, so we need it clear. */ + o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ @@ -1095,6 +1099,7 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_next = (OP*)newop; kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; + newop->op_private &= ~1; break; } @@ -1129,6 +1134,7 @@ Perl_mod(pTHX_ OP *o, I32 type) okid->op_targ = 0; okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; okid->op_private |= OPpLVAL_INTRO; + okid->op_private &= ~1; break; } @@ -1446,6 +1452,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; + o->op_private &= ~1; } break; @@ -5362,6 +5369,9 @@ Perl_ck_rvconst(pTHX_ register OP *o) SVOP * const kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); + if (o->op_type == OP_RV2CV) + o->op_private &= ~1; + if (kid->op_type == OP_CONST) { int iscv; GV *gv; @@ -7298,6 +7308,54 @@ Perl_peep(pTHX_ register OP *o) break; } + + case OP_SASSIGN: { + OP *rv2gv; + UNOP *refgen, *rv2cv; + LISTOP *exlist; + + /* I do not understand this, but if o->op_opt isn't set to 1, + various tests in ext/B/t/bytecode.t fail with no readily + apparent cause. */ + + o->op_opt = 1; + + if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) + break; + + rv2gv = ((BINOP *)o)->op_last; + if (!rv2gv || rv2gv->op_type != OP_RV2GV) + break; + + refgen = (UNOP *)((BINOP *)o)->op_first; + + if (!refgen || refgen->op_type != OP_REFGEN) + break; + + exlist = (LISTOP *)refgen->op_first; + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_first->op_type != OP_PUSHMARK) + break; + + rv2cv = (UNOP*)exlist->op_last; + + if (rv2cv->op_type != OP_RV2CV) + break; + + assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); + assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); + assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); + + o->op_private |= OPpASSIGN_CV_TO_GV; + rv2gv->op_private |= OPpDONT_INIT_GV; + rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; + + break; + } + default: o->op_opt = 1; @@ -140,6 +140,7 @@ Deprecated. Use C<GIMME_V> instead. /* Private for OP_SASSIGN */ #define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */ +#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */ /* Private for OP_MATCH and OP_SUBST{,CONST} */ #define OPpRUNTIME 64 /* Pattern coming in on the stack */ @@ -181,6 +182,14 @@ Deprecated. Use C<GIMME_V> instead. #define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */ /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */ + /* OP_RV2GV only */ +#define OPpDONT_INIT_GV 8 /* Call gv_fetchpv with GV_NOINIT */ +/* (Therefore will return whatever is currently in the symbol table, not + guaranteed to be a PVGV) */ + + /* OP_RV2CV only */ +#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */ + /* Private for OPs with TARGLEX */ /* (lower bits may carry MAXARG) */ #define OPpTARGET_MY 16 /* Target is PADMY. */ @@ -202,6 +202,13 @@ PP(pp_rv2gv) else { if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref_sv, sv, "a symbol"); + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) + == OPpDONT_INIT_GV) { + /* We are the target of a coderef assignment. Return + the scalar unchanged, and let pp_sasssign deal with + things. */ + RETURN; + } sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV); } } @@ -337,11 +344,13 @@ PP(pp_rv2cv) dSP; GV *gv; HV *stash; - + I32 flags = (PL_op->op_flags & OPf_SPECIAL) ? 0 + : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) + == OPpMAY_RETURN_CONSTANT) ? GV_ADD|GV_NOEXPAND : GV_ADD; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ - CV *cv = sv_2cv(TOPs, &stash, &gv, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : GV_ADD); + + CV *cv = sv_2cv(TOPs, &stash, &gv, flags); if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -352,6 +361,9 @@ PP(pp_rv2cv) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } } + else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { + cv = (CV*)gv; + } else cv = (CV*)&PL_sv_undef; SETs((SV*)cv); @@ -116,6 +116,60 @@ PP(pp_sassign) } if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; + if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { + SV *cv = SvRV(left); + const U32 cv_type = SvTYPE(cv); + const U32 gv_type = SvTYPE(right); + bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; + + if (!got_coderef) { + assert(SvROK(cv)); + } + + /* Can do the optimisation if right (LVAUE) is not a typeglob, + left (RVALUE) is a reference to something, and we're in void + context. */ + if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) { + /* Is the target symbol table currently empty? */ + GV *gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV); + if (!SvOK(gv)) { + /* Good. Create a new proxy constant subroutine in the target. + The gv becomes a(nother) reference to the constant. */ + SV *const value = SvRV(cv); + + SvUPGRADE((SV *)gv, SVt_RV); + SvROK_on(gv); + SvRV_set(gv, value); + SvREFCNT_inc(value); + SETs(right); + RETURN; + } + } + + /* Need to fix things up. */ + if (gv_type != SVt_PVGV) { + /* Need to fix GV. */ + right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV); + } + + if (!got_coderef) { + /* We've been returned a constant rather than a full subroutine, + but they expect a subroutine reference to apply. */ + ENTER; + SvREFCNT_inc(SvRV(cv)); + /* newCONSTSUB takes a reference count on the passed in SV + from us. We set the name to NULL, otherwise we get into + all sorts of fun as the reference to our new sub is + donated to the GV that we're about to assign to. + */ + SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL, + SvRV(cv))); + SvREFCNT_dec(cv); + LEAVE; + PerlIO_debug("Unwrap CV\n"); + } + + } SvSetMagicSV(right, left); SETs(right); RETURN; @@ -6778,6 +6778,11 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) *st = NULL; return Nullcv; } + /* Some flags to gv_fetchsv mean don't really create the GV */ + if (SvTYPE(gv) != SVt_PVGV) { + *st = NULL; + return NULL; + } *st = GvESTASH(gv); fix_gv: if (lref && !GvCVu(gv)) { |