Add an optimisation to allow proxy constant subroutines to be copied

as proxy constant subroutines in a new symbol table where possible.
(Rather than converting them to full blown constant subroutines and
instantiating 2 typeglobs)

p4raw-id: //depot/perl@26446

diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index 0ac1aea..b2b840b 100644 (file)
--- 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");
 

diff --git a/gv.c b/gv.c
index 418e08c..4763cd8 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -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 */

diff --git a/gv.h b/gv.h
index 73814a8..a97d4ba 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -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.

diff --git a/op.c b/op.c
index 5bd7644..e8e0193 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;

diff --git a/op.h b/op.h
index b3f91aa..74bc179 100644 (file)
--- a/op.h
+++ b/op.h
@@ -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. */

diff --git a/pp.c b/pp.c
index ae893bc..28fa03f 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -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);

diff --git a/pp_hot.c b/pp_hot.c
index 285e1e5..c625c2c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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;

diff --git a/sv.c b/sv.c
index c9f2e27..d8f2824 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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)) {