This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid creating GVs when subs are declared
authorFather Chrysostomos <sprout@cpan.org>
Mon, 1 Sep 2014 03:13:21 +0000 (20:13 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 13:19:32 +0000 (06:19 -0700)
This patch changes ‘sub foo {...}’ declarations to store subroutine
references in the stash, to save memory.

Typeglobs still notionally exist.  Accessing CvGV(cv) will reify them.
Hence, currently the savings are lost when a sub call is compiled.

$ ./miniperl -e 'sub foo{} BEGIN { warn $::{foo} } foo(); BEGIN { warn $::{foo} }'
CODE(0x7f8ef082ad98) at -e line 1.
*main::foo at -e line 1.

This optimisation is skipped if the subroutine declaration contains a
package separator.

Concerning the changes in caller.t, this code:

    sub foo { print +(caller(0))[3],"\n" }
    my $fooref = delete $::{foo};
    $fooref -> ();

used to crash in 5.7.3 or thereabouts.  It was fixed by 16658 (aka
07b8c804e8) to produce ‘(unknown)’ instead.  Then in 5.13.3 it was
changed (by 803f274) to produce ‘main::__ANON__’ instead.  So the
tests are really checking that we don’t get a crash.  I think it is
acceptable that it has now changed to ‘main::foo’.

embed.fnc
gv.c
op.c
pp.c
proto.h
t/op/caller.t
t/op/gv.t
t/uni/gv.t
t/uni/parser.t
toke.c
universal.c

index 74f1ba9..4378152 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1941,7 +1941,7 @@ s |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode \
                                |PADOFFSET entertarg
 s      |OP*    |ref_array_or_hash|NULLOK OP* cond
-s      |void   |process_special_blocks |I32 floor \
+s      |bool   |process_special_blocks |I32 floor \
                                        |NN const char *const fullname\
                                        |NN GV *const gv|NN CV *const cv
 s      |void   |clear_special_blocks   |NN const char *const fullname\
diff --git a/gv.c b/gv.c
index 7aa9f1e..1b490f8 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -260,17 +260,25 @@ GV *
 Perl_cvgv_from_hek(pTHX_ CV *cv)
 {
     GV *gv;
+    SV **svp;
     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
     assert(SvTYPE(cv) == SVt_PVCV);
     if (!CvSTASH(cv)) return NULL;
     ASSUME(CvNAME_HEK(cv));
-    gv = (GV *)newSV(0);
-    gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
+    svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
+    gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
+    if (!isGV(gv))
+       gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
                HEK_LEN(CvNAME_HEK(cv)),
                SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
+    if (!CvNAMED(cv)) { /* gv_init took care of it */
+       assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
+       return gv;
+    }
     unshare_hek(CvNAME_HEK(cv));
     CvNAMED_off(cv);
     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+    if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
     CvCVGV_RC_on(cv);
     return gv;
 }
@@ -370,10 +378,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     assert (!(proto && has_constant));
 
     if (has_constant) {
-       /* The constant has to be a simple scalar type.  */
+       /* The constant has to be a scalar, array or subroutine.  */
        switch (SvTYPE(has_constant)) {
        case SVt_PVHV:
-       case SVt_PVCV:
        case SVt_PVFM:
        case SVt_PVIO:
             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
@@ -409,7 +416,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
     if (flags & GV_ADDMULTI || doproto)        /* doproto means it */
        GvMULTI_on(gv);                 /* _was_ mentioned */
-    if (doproto) {
+    if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+       /* Not actually a constant.  Just a regular sub.  */
+       CV * const cv = (CV *)has_constant;
+       GvCV_set(gv,cv);
+       if (CvSTASH(cv) == stash && (
+              CvNAME_HEK(cv) == GvNAME_HEK(gv)
+           || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
+              && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
+              && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
+              && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
+              )
+          ))
+           CvGV_set(cv,gv);
+    }
+    else if (doproto) {
        CV *cv;
        if (has_constant) {
            /* newCONSTSUB takes ownership of the reference from us.  */
diff --git a/op.c b/op.c
index be9a341..78407f3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2393,6 +2393,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
            else {                      /* Compile-time error message: */
                OP *kid = cUNOPo->op_first;
                CV *cv;
+               GV *gv;
 
                if (kid->op_type != OP_PUSHMARK) {
                    if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
@@ -2420,7 +2421,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
                    break;
                }
 
-               cv = GvCV(kGVOP_gv);
+               gv = kGVOP_gv;
+               cv = isGV(gv)
+                   ? GvCV(gv)
+                   : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+                       ? MUTABLE_CV(SvRV(gv))
+                       : NULL;
                if (!cv)
                    break;
                if (CvLVALUE(cv))
@@ -7058,12 +7064,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block)
     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
 }
 
+/* must not conflict with SVf_UTF8 */
+#define CV_CKPROTO_CURSTASH    0x1
+
 void
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
                    const STRLEN len, const U32 flags)
 {
     SV *name = NULL, *msg;
-    const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+    const char * cvp = SvROK(cv)
+                       ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
+                          ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
+                          : ""
+                       : CvPROTO(cv);
     STRLEN clen = CvPROTOLEN(cv), plen = len;
 
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
@@ -7100,6 +7113,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
            gv_efullname3(name = sv_newmortal(), gv, NULL);
        else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
            name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+       else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
+           name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
+           sv_catpvs(name, "::");
+           if (SvROK(gv)) {
+               assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
+               assert (CvNAMED(SvRV_const(gv)));
+               sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
+           }
+           else sv_catsv(name, (SV *)gv);
+       }
        else name = (SV *)gv;
     }
     sv_setpvs(msg, "Prototype mismatch:");
@@ -7652,7 +7675,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     /* If the subroutine has no body, no attributes, and no builtin attributes
        then it's just a sub declaration, and we may be able to get away with
        storing with a placeholder scalar in the symbol table, rather than a
-       full GV and CV.  If anything is present then it will take a full CV to
+       full CV.  If anything is present then it will take a full CV to
        store it.  */
     const I32 gv_fetch_flags
        = ec ? GV_NOADD_NOINIT :
@@ -7666,13 +7689,27 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
 #endif
+    bool special = FALSE;
 
     if (o_is_gv) {
        gv = (GV*)o;
        o = NULL;
        has_name = TRUE;
     } else if (name) {
-       gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+       /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
+          hek and CvSTASH pointer together can imply the GV.  If the name
+          contains a package name, then GvSTASH(CvGV(cv)) may differ from
+          CvSTASH, so forego the optimisation if we find any.
+          Also, we may be called from load_module at run time, so
+          PL_curstash (which sets CvSTASH) may not point to the stash the
+          sub is stored in.  */
+       const I32 flags =
+          ec ? GV_NOADD_NOINIT
+             :   PL_curstash != CopSTASH(PL_curcop)
+              || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
+                   ? gv_fetch_flags
+                   : GV_ADDMULTI | GV_NOINIT;
+       gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
        has_name = TRUE;
     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
        SV * const sv = sv_newmortal();
@@ -7689,7 +7726,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        has_name = FALSE;
     }
     if (!ec)
-        move_proto_attr(&proto, &attrs, gv);
+       move_proto_attr(&proto, &attrs,
+                       isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
 
     if (proto) {
        assert(proto->op_type == OP_CONST);
@@ -7728,8 +7766,18 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        goto done;
     }
 
-    if (SvTYPE(gv) != SVt_PVGV) {      /* Maybe prototype now, and had at
-                                          maximum a prototype before. */
+    if (!block && SvTYPE(gv) != SVt_PVGV) {
+      /* If we are not defining a new sub and the existing one is not a
+         full GV + CV... */
+      if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+       /* We are applying attributes to an existing sub, so we need it
+          upgraded if it is a constant.  */
+       if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+           gv_init_pvn(gv, PL_curstash, name, namlen,
+                       SVf_UTF8 * name_is_utf8);
+      }
+      else {                   /* Maybe prototype now, and had at maximum
+                                  a prototype or const/sub ref before.  */
        if (SvTYPE(gv) > SVt_NULL) {
            cv_ckproto_len_flags((const CV *)gv,
                                 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
@@ -7747,9 +7795,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        SvREFCNT_dec(PL_compcv);
        cv = PL_compcv = NULL;
        goto done;
+      }
     }
 
-    cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
+    cv = (!name || (isGV(gv) && GvCVGEN(gv)))
+       ? NULL
+       : isGV(gv)
+           ? GvCV(gv)
+           : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+               ? (CV *)SvRV(gv)
+               : NULL;
+
 
     if (!block || !ps || *ps || attrs
        || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
@@ -7758,6 +7814,38 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     else
        const_sv = op_const_sv(block, NULL);
 
+    if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
+       assert (block);
+       cv_ckproto_len_flags((const CV *)gv,
+                            o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+                            ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
+       if (SvROK(gv)) {
+           /* All the other code for sub redefinition warnings expects the
+              clobbered sub to be a CV.  Instead of making all those code
+              paths more complex, just inline the RV version here.  */
+           const line_t oldline = CopLINE(PL_curcop);
+           assert(IN_PERL_COMPILETIME);
+           if (PL_parser && PL_parser->copline != NOLINE)
+               /* This ensures that warnings are reported at the first
+                  line of a redefinition, not the last.  */
+               CopLINE_set(PL_curcop, PL_parser->copline);
+           /* protect against fatal warnings leaking compcv */
+           SAVEFREESV(PL_compcv);
+
+           if (ckWARN(WARN_REDEFINE)
+            || (  ckWARN_d(WARN_REDEFINE)
+               && (  !const_sv || SvRV(gv) == const_sv
+                  || sv_cmp(SvRV(gv), const_sv)  )))
+               Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                         "Constant subroutine %"SVf" redefined",
+                         SVfARG(cSVOPo->op_sv));
+
+           SvREFCNT_inc_simple_void_NN(PL_compcv);
+           CopLINE_set(PL_curcop, oldline);
+           SvREFCNT_dec(SvRV(gv));
+       }
+    }
+
     if (cv) {
         const bool exists = CvROOT(cv) || CvXSUB(cv);
 
@@ -7768,7 +7856,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         if (exists || SvPOK(cv))
             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
        /* already defined (or promised)? */
-       if (exists || GvASSUMECV(gv)) {
+       if (exists || (isGV(gv) && GvASSUMECV(gv))) {
            if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
                cv = NULL;
            else {
@@ -7792,11 +7880,22 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            CvISXSUB_on(cv);
        }
        else {
-           if (name) GvCV_set(gv, NULL);
-           cv = newCONSTSUB_flags(
-               NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
-               const_sv
-           );
+           if (isGV(gv)) {
+               if (name) GvCV_set(gv, NULL);
+               cv = newCONSTSUB_flags(
+                   NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+                   const_sv
+               );
+           }
+           else {
+               if (!SvROK(gv)) {
+                   SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+                   prepare_SV_for_RV((SV *)gv);
+                   SvOK_off((SV *)gv);
+                   SvROK_on(gv);
+               }
+               SvRV_set(gv, const_sv);
+           }
        }
        op_free(block);
        SvREFCNT_dec(PL_compcv);
@@ -7814,12 +7913,23 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
            OP * const cvstart = CvSTART(cv);
 
-           CvGV_set(cv,gv);
-           assert(!CvCVGV_RC(cv));
-           assert(CvGV(cv) == gv);
+           if (isGV(gv)) {
+               CvGV_set(cv,gv);
+               assert(!CvCVGV_RC(cv));
+               assert(CvGV(cv) == gv);
+           }
+           else {
+               U32 hash;
+               PERL_HASH(hash, name, namlen);
+               CvNAME_HEK_set(cv,
+                              share_hek(name,
+                                        name_is_utf8 ? -namlen : namlen,
+                                        hash));
+           }
 
            SvPOK_off(cv);
-           CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+           CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
+                                            | CvNAMED(cv);
            CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
            CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
            CvPADLIST(cv) = CvPADLIST(PL_compcv);
@@ -7851,16 +7961,32 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     }
     else {
        cv = PL_compcv;
-       if (name) {
+       if (name && isGV(gv)) {
            GvCV_set(gv, cv);
            GvCVGEN(gv) = 0;
            if (HvENAME_HEK(GvSTASH(gv)))
                /* sub Foo::bar { (shift)+1 } */
                gv_method_changed(gv);
        }
+       else if (name) {
+           if (!SvROK(gv)) {
+               SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+               prepare_SV_for_RV((SV *)gv);
+               SvOK_off((SV *)gv);
+               SvROK_on(gv);
+           }
+           SvRV_set(gv, (SV *)cv);
+       }
     }
-    if (!CvGV(cv)) {
-       CvGV_set(cv, gv);
+    if (!CvHASGV(cv)) {
+       if (isGV(gv)) CvGV_set(cv, gv);
+       else {
+           U32 hash;
+           PERL_HASH(hash, name, namlen);
+           CvNAME_HEK_set(cv, share_hek(name,
+                                        name_is_utf8 ? -namlen : namlen,
+                                        hash));
+       }
        CvFILE_set_from_cop(cv, PL_curcop);
        CvSTASH_set(cv, PL_curstash);
     }
@@ -7917,7 +8043,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
   attrs:
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
-       HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+       HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
+                       ? GvSTASH(CvGV(cv))
+                       : PL_curstash;
        if (!name) SAVEFREESV(cv);
        apply_attrs(stash, MUTABLE_SV(cv), attrs);
        if (!name) SvREFCNT_inc_simple_void_NN(cv);
@@ -7925,7 +8053,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 
     if (block && has_name) {
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
-           SV * const tmpstr = sv_newmortal();
+           SV * const tmpstr = cv_name(cv,NULL);
            GV * const db_postponed = gv_fetchpvs("DB::postponed",
                                                  GV_ADDMULTI, SVt_PVHV);
            HV *hv;
@@ -7933,7 +8061,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                                          CopFILE(PL_curcop),
                                          (long)PL_subline,
                                          (long)CopLINE(PL_curcop));
-           gv_efullname3(tmpstr, gv, NULL);
            (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
                    SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
            hv = GvHVn(db_postponed);
@@ -7953,7 +8080,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
             if (PL_parser && PL_parser->error_count)
                 clear_special_blocks(name, gv, cv);
             else
-                process_special_blocks(floor, name, gv, cv);
+                special = process_special_blocks(floor, name, gv, cv);
         }
     }
 
@@ -7963,7 +8090,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     LEAVE_SCOPE(floor);
 #ifdef PERL_DEBUG_READONLY_OPS
     /* Watch out for BEGIN blocks */
-    if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+    if (!special) Slab_to_ro(slab);
 #endif
     return cv;
 }
@@ -7984,12 +8111,16 @@ S_clear_special_blocks(pTHX_ const char *const fullname,
         || (*name == 'U' && strEQ(name, "UNITCHECK"))
         || (*name == 'C' && strEQ(name, "CHECK"))
         || (*name == 'I' && strEQ(name, "INIT"))) {
+        if (!isGV(gv)) {
+            (void)CvGV(cv);
+            assert(isGV(gv));
+        }
         GvCV_set(gv, NULL);
         SvREFCNT_dec_NN(MUTABLE_SV(cv));
     }
 }
 
-STATIC void
+STATIC bool
 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                         GV *const gv,
                         CV *const cv)
@@ -8003,6 +8134,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
        if (strEQ(name, "BEGIN")) {
            const I32 oldscope = PL_scopestack_ix;
             dSP;
+            (void)CvGV(cv);
            if (floor) LEAVE_SCOPE(floor);
            ENTER;
             PUSHSTACKi(PERLSI_REQUIRE);
@@ -8017,23 +8149,24 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
 
             POPSTACK;
            LEAVE;
+           return TRUE;
        }
        else
-           return;
+           return FALSE;
     } else {
        if (*name == 'E') {
            if strEQ(name, "END") {
                DEBUG_x( dump_sub(gv) );
                Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
            } else
-               return;
+               return FALSE;
        } else if (*name == 'U') {
            if (strEQ(name, "UNITCHECK")) {
                /* It's never too late to run a unitcheck block */
                Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
            }
            else
-               return;
+               return FALSE;
        } else if (*name == 'C') {
            if (strEQ(name, "CHECK")) {
                if (PL_main_start)
@@ -8043,7 +8176,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
            }
            else
-               return;
+               return FALSE;
        } else if (*name == 'I') {
            if (strEQ(name, "INIT")) {
                if (PL_main_start)
@@ -8053,11 +8186,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
            }
            else
-               return;
+               return FALSE;
        } else
-           return;
+           return FALSE;
        DEBUG_x( dump_sub(gv) );
+       (void)CvGV(cv);
        GvCV_set(gv,0);         /* cv has been hijacked */
+       return TRUE;
     }
 }
 
@@ -10143,6 +10278,11 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
        case OP_GV: {
            gv = cGVOPx_gv(rvop);
            if (!isGV(gv)) {
+               if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
+                   cv = MUTABLE_CV(SvRV(gv));
+                   gv = NULL;
+                   break;
+               }
                if (flags & RV2CVOPCV_RETURN_STUB)
                    return (CV *)gv;
                else return NULL;
@@ -11358,7 +11498,7 @@ Perl_rpeep(pTHX_ OP *o)
                 OP *rv2av, *q;
                 p = o->op_next;
                 if (   p->op_type == OP_GV
-                    && (gv = cGVOPx_gv(p))
+                    && (gv = cGVOPx_gv(p)) && isGV(gv)
                     && GvNAMELEN_get(gv) == 1
                     && *GvNAME_get(gv) == '_'
                     && GvSTASH(gv) == PL_defstash
diff --git a/pp.c b/pp.c
index 7cadace..ea05bb4 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -472,7 +472,9 @@ PP(pp_rv2cv)
     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
     if (cv) NOOP;
     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
-       cv = MUTABLE_CV(gv);
+       cv = SvTYPE(SvRV(gv)) == SVt_PVCV
+           ? MUTABLE_CV(SvRV(gv))
+           : MUTABLE_CV(gv);
     }    
     else
        cv = MUTABLE_CV(&PL_sv_undef);
diff --git a/proto.h b/proto.h
index 642823d..a540fc7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6265,7 +6265,7 @@ STATIC OP*        S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl)
 #define PERL_ARGS_ASSERT_PMTRANS       \
        assert(o); assert(expr); assert(repl)
 
-STATIC void    S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv)
+STATIC bool    S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)
                        __attribute__nonnull__(pTHX_4);
index c43f576..e0534ba 100644 (file)
@@ -31,7 +31,7 @@ ok( $c[4], "hasargs true with anon sub" );
 sub foo { @c = caller(0) }
 my $fooref = delete $::{foo};
 $fooref -> ();
-is( $c[3], "main::__ANON__", "deleted subroutine name" );
+is( $c[3], "main::foo", "deleted subroutine name" );
 ok( $c[4], "hasargs true with deleted sub" );
 
 BEGIN {
@@ -66,7 +66,7 @@ ok( $c[4], "hasargs true with anon sub" );
 sub foo2 { f() }
 my $fooref2 = delete $::{foo2};
 $fooref2 -> ();
-is( $c[3], "main::__ANON__", "deleted subroutine name" );
+is( $c[3], "main::foo2", "deleted subroutine name" );
 ok( $c[4], "hasargs true with deleted sub" );
 
 # See if caller() returns the correct warning mask
index 279a9af..4c8c79d 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -490,6 +490,9 @@ is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args';
 is prototype "yarrow", "", 'const list has "" prototype';
 is eval "yarrow", 3, 'const list in scalar cx returns length';
 
+$::{borage} = \&ok;
+eval 'borage("sub ref in stash")' or fail "sub ref in stash";
+
 {
     use vars qw($glook $smek $foof);
     # Check reference assignment isn't affected by the SV type (bug #38439)
@@ -512,7 +515,7 @@ is eval "yarrow", 3, 'const list in scalar cx returns length';
 format =
 .
 
-foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
     # IO::Handle, which isn't what we want.
     my $type = $value;
index 9143034..9c48cef 100644 (file)
@@ -15,7 +15,7 @@ use utf8;
 use open qw( :utf8 :std );
 use warnings;
 
-plan( tests => 207 );
+plan( tests => 206 );
 
 # type coersion on assignment
 $ᕘ = 'ᕘ';
@@ -492,7 +492,7 @@ no warnings 'once';
 format =
 .
     
-    foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+    foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
         # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
         # IO::Handle, which isn't what we want.
         my $type = $value;
index 2437e3d..83ffd8e 100644 (file)
@@ -8,7 +8,7 @@ BEGIN {
     skip_all_without_unicode_tables();
 }
 
-plan (tests => 52);
+plan (tests => 51);
 
 use utf8;
 use open qw( :utf8 :std );
@@ -82,8 +82,7 @@ closedir FÒÒ;
 sub участники { 1 }
 
 ok $::{"участники"}, "non-const sub declarations generate the right glob";
-ok *{$::{"участники"}}{CODE};
-is *{$::{"участники"}}{CODE}->(), 1;
+is $::{"участники"}->(), 1;
 
 sub 原 () { 1 }
 
diff --git a/toke.c b/toke.c
index ea022f9..8a8d187 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6552,7 +6552,11 @@ Perl_yylex(pTHX)
                    rv2cv_op =
                        newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
                    cv = lex
-                       ? isGV(gv) ? GvCV(gv) : (CV *)gv
+                       ? isGV(gv)
+                           ? GvCV(gv)
+                           : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+                               ? (CV *)SvRV(gv)
+                               : (CV *)gv
                        : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
                }
 
index 200ce87..825dff5 100644 (file)
@@ -303,11 +303,11 @@ void
 Perl_croak_xs_usage(const CV *const cv, const char *const params)
 {
     /* Avoid CvGV as it requires aTHX.  */
-    const GV *const gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
+    const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
 
     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 
-    if (gv) {
+    if (gv) got_gv: {
        const HV *const stash = GvSTASH(gv);
 
        if (HvNAME_get(stash))
@@ -321,6 +321,9 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params)
            Perl_croak_nocontext("Usage: %"HEKf"(%s)",
                                 HEKfARG(GvNAME_HEK(gv)), params);
     } else {
+        dTHX;
+        if ((gv = CvGV(cv))) goto got_gv;
+
        /* Pants. I don't think that it should be possible to get here. */
        /* diag_listed_as: SKIPME */
        Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);