Re: Creating const subs for constants.

Message-Id: <m13mo0N-000FObC@feynman.localnet>

p4raw-id: //depot/perl@7389

diff --git a/cv.h b/cv.h
index adb424e..6fa1f4f 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -75,6 +75,7 @@ Returns the stash of the CV.
 #define CVf_METHOD     0x0040  /* CV is explicitly marked as a method */
 #define CVf_LOCKED     0x0080  /* CV locks itself or first arg on entry */
 #define CVf_LVALUE     0x0100  /* CV return value can be used as lvalue */
+#define CVf_CONST      0x0200  /* inlinable sub */
 
 #define CvCLONE(cv)            (CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)         (CvFLAGS(cv) |= CVf_CLONE)
@@ -122,3 +123,7 @@ Returns the stash of the CV.
 #define CvSPECIAL(cv)          (CvUNIQUE(cv) && SvFAKE(cv))
 #define CvSPECIAL_on(cv)       (CvUNIQUE_on(cv),SvFAKE_on(cv))
 #define CvSPECIAL_off(cv)      (CvUNIQUE_off(cv),SvFAKE_off(cv))
+
+#define CvCONST(cv)            (CvFLAGS(cv) & CVf_CONST)
+#define CvCONST_on(cv)         (CvFLAGS(cv) |= CVf_CONST)
+#define CvCONST_off(cv)                (CvFLAGS(cv) &= ~CVf_CONST)

diff --git a/embed.pl b/embed.pl
index e846cac..f685042 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1441,7 +1441,7 @@ Afnp      |int    |fprintf_nocontext|PerlIO* stream|const char* fmt|...
 #endif
 p      |void   |cv_ckproto     |CV* cv|GV* gv|char* p
 p      |CV*    |cv_clone       |CV* proto
-Ap     |SV*    |cv_const_sv    |CV* cv
+Apd    |SV*    |cv_const_sv    |CV* cv
 p      |SV*    |op_const_sv    |OP* o|CV* cv
 Ap     |void   |cv_undef       |CV* cv
 Ap     |void   |cx_dump        |PERL_CONTEXT* cs
@@ -1761,7 +1761,7 @@ Ap        |OP*    |newANONHASH    |OP* o
 Ap     |OP*    |newANONSUB     |I32 floor|OP* proto|OP* block
 Ap     |OP*    |newASSIGNOP    |I32 flags|OP* left|I32 optype|OP* right
 Ap     |OP*    |newCONDOP      |I32 flags|OP* expr|OP* trueop|OP* falseop
-Apd    |void   |newCONSTSUB    |HV* stash|char* name|SV* sv
+Apd    |CV*    |newCONSTSUB    |HV* stash|char* name|SV* sv
 Ap     |void   |newFORM        |I32 floor|OP* o|OP* block
 Ap     |OP*    |newFOROP       |I32 flags|char* label|line_t forline \
                                |OP* sclr|OP* expr|OP*block|OP*cont

diff --git a/op.c b/op.c
index 84a1df9..6ef4bfe 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4112,6 +4112,10 @@ Perl_cv_undef(pTHX_ CV *cv)
     CvGV(cv) = Nullgv;
     SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
+    if (CvCONST(cv)) {
+       SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
+       CvCONST_off(cv);
+    }
     if (CvPADLIST(cv)) {
        /* may be during global destruction */
        if (SvREFCNT(CvPADLIST(cv))) {
@@ -4312,6 +4316,15 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 #endif
 
     LEAVE;
+
+    if (CvCONST(cv)) {
+       SV* const_sv = op_const_sv(CvSTART(cv), cv);
+       assert(const_sv);
+       /* constant sub () { $x } closing over $x - see lib/constant.pm */
+       SvREFCNT_dec(cv);
+       cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+    }
+
     return cv;
 }
 
@@ -4350,12 +4363,25 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
     }
 }
 
+static void const_sv_xsub(pTHXo_ CV* cv);
+
+/*
+=for apidoc cv_const_sv
+
+If C<cv> is a constant sub eligible for inlining. returns the constant
+value returned by the sub.  Otherwise, returns NULL.
+
+Constant subs can be created with C<newCONSTSUB> or as described in
+L<perlsub/"Constant Functions">.
+
+=cut
+*/
 SV *
 Perl_cv_const_sv(pTHX_ CV *cv)
 {
-    if (!cv || !SvPOK(cv) || SvCUR(cv))
+    if (!cv || !CvCONST(cv))
        return Nullsv;
-    return op_const_sv(CvSTART(cv), cv);
+    return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
 SV *
@@ -4385,7 +4411,17 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
        else if ((type == OP_PADSV || type == OP_CONST) && cv) {
            AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
            sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
-           if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
+           if (!sv)
+               return Nullsv;
+           if (CvCONST(cv)) {
+               /* We get here only from cv_clone2() while creating a closure.
+                  Copy the const value here instead of in cv_clone2 so that
+                  SvREADONLY_on doesn't lead to problems when leaving
+                  scope.
+               */
+               sv = newSVsv(sv);
+           }
+           if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
                return Nullsv;
        }
        else
@@ -4427,6 +4463,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
+    SV *const_sv;
 
     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
@@ -4465,12 +4502,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        SvREFCNT_dec(PL_compcv);
        cv = PL_compcv = NULL;
        PL_sub_generation++;
-       goto noblock;
+       goto done;
     }
 
-    if (!name || GvCVGEN(gv))
-       cv = Nullcv;
-    else if ((cv = GvCV(gv))) {
+    cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
+
+    if (!block || !ps || *ps || attrs)
+       const_sv = Nullsv;
+    else
+       const_sv = op_const_sv(block, Nullcv);
+
+    if (cv) {
         bool exists = CvROOT(cv) || CvXSUB(cv);
         /* if the subroutine doesn't exist and wasn't pre-declared
          * with a prototype, assume it will be AUTOLOADed,
@@ -4480,8 +4522,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            cv_ckproto(cv, gv, ps);
        /* already defined (or promised)? */
        if (exists || GvASSUMECV(gv)) {
-           SV* const_sv;
-           bool const_changed = TRUE;
            if (!block && !attrs) {
                /* just a "sub foo;" when &foo is already defined */
                SAVEFREESV(PL_compcv);
@@ -4490,24 +4530,43 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            /* ahem, death to those who redefine active sort subs */
            if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
                Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
-           if (!block)
-               goto withattrs;
-           if ((const_sv = cv_const_sv(cv)))
-               const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
-            if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE))
-           {
-               line_t oldline = CopLINE(PL_curcop);
-               CopLINE_set(PL_curcop, PL_copline);
-               Perl_warner(aTHX_ WARN_REDEFINE,
-                       const_sv ? "Constant subroutine %s redefined"
-                                : "Subroutine %s redefined", name);
-               CopLINE_set(PL_curcop, oldline);
+           if (block) {
+               if (ckWARN(WARN_REDEFINE)
+                   || (CvCONST(cv)
+                       && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
+               {
+                   line_t oldline = CopLINE(PL_curcop);
+                   CopLINE_set(PL_curcop, PL_copline);
+                   Perl_warner(aTHX_ WARN_REDEFINE,
+                       CvCONST(cv) ? "Constant subroutine %s redefined"
+                                   : "Subroutine %s redefined", name);
+                   CopLINE_set(PL_curcop, oldline);
+               }
+               SvREFCNT_dec(cv);
+               cv = Nullcv;
            }
-           SvREFCNT_dec(cv);
-           cv = Nullcv;
        }
     }
-  withattrs:
+    if (const_sv) {
+       SvREFCNT_inc(const_sv);
+       if (cv) {
+           cv_undef(cv);
+           sv_setpv((SV*)cv, "");  /* prototype is "" */
+           CvXSUBANY(cv).any_ptr = const_sv;
+           CvXSUB(cv) = const_sv_xsub;
+           CvCONST_on(cv);
+           /* XXX Does anybody care that CvFILE(cv) is blank? */
+       }
+       else {
+           GvCV(gv) = Nullcv;
+           cv = newCONSTSUB(NULL, name, const_sv);
+       }
+       op_free(block);
+       SvREFCNT_dec(PL_compcv);
+       PL_compcv = NULL;
+       PL_sub_generation++;
+       goto done;
+    }
     if (attrs) {
        HV *stash;
        SV *rcv;
@@ -4591,12 +4650,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            }
        }
     }
-    if (!block) {
-      noblock:
-       PL_copline = NOLINE;
-       LEAVE_SCOPE(floor);
-       return cv;
-    }
+    if (!block)
+       goto done;
 
     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
        av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
@@ -4635,6 +4690,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                PL_curpad[ix] = Nullsv;
            }
        }
+       assert(!CvCONST(cv));
+       if (ps && !*ps && op_const_sv(block, cv))
+           CvCONST_on(cv);
     }
     else {
        AV *av = newAV();                       /* Will be @_ */
@@ -4750,10 +4808,11 @@ eligible for inlining at compile-time.
 =cut
 */
 
-void
+CV *
 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
 {
     dTHR;
+    CV* cv;
 
     ENTER;
 
@@ -4774,15 +4833,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
 #endif
     }
 
-    newATTRSUB(
-       start_subparse(FALSE, 0),
-       newSVOP(OP_CONST, 0, newSVpv(name,0)),
-       newSVOP(OP_CONST, 0, &PL_sv_no),        /* SvPV(&PL_sv_no) == "" -- GMB */
-       Nullop,
-       newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
-    );
+    cv = newXS(name, const_sv_xsub, __FILE__);
+    CvXSUBANY(cv).any_ptr = sv;
+    CvCONST_on(cv);
+    sv_setpv((SV*)cv, "");  /* prototype is "" */
 
     LEAVE;
+
+    return cv;
 }
 
 /*
@@ -4814,7 +4872,10 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
                line_t oldline = CopLINE(PL_curcop);
                if (PL_copline != NOLINE)
                    CopLINE_set(PL_curcop, PL_copline);
-               Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name);
+               Perl_warner(aTHX_ WARN_REDEFINE,
+                           CvCONST(cv) ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined"
+                           ,name);
                CopLINE_set(PL_curcop, oldline);
            }
            SvREFCNT_dec(cv);
@@ -6843,3 +6904,14 @@ Perl_peep(pTHX_ register OP *o)
     }
     LEAVE;
 }
+
+#include "XSUB.h"
+
+/* Efficient sub that returns a constant scalar value. */
+static void
+const_sv_xsub(pTHXo_ CV* cv)
+{
+    dXSARGS;
+    ST(0) = sv_2mortal(newSVsv((SV*)XSANY.any_ptr));
+    XSRETURN(1);
+}

diff --git a/perlapi.c b/perlapi.c
index 9eb4175..3cfe4e0 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -1743,10 +1743,10 @@ Perl_newCONDOP(pTHXo_ I32 flags, OP* expr, OP* trueop, OP* falseop)
 }
 
 #undef  Perl_newCONSTSUB
-void
+CV*
 Perl_newCONSTSUB(pTHXo_ HV* stash, char* name, SV* sv)
 {
-    ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv);
+    return ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv);
 }
 
 #undef  Perl_newFORM

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 98abdc1..a5178e8 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -287,6 +287,19 @@ Returns the stash of the CV.
 =for hackers
 Found in file cv.h
 
+=item cv_const_sv
+
+If C<cv> is a constant sub eligible for inlining. returns the constant
+value returned by the sub.  Otherwise, returns NULL.
+
+Constant subs can be created with C<newCONSTSUB> or as described in
+L<perlsub/"Constant Functions">.
+
+       SV*     cv_const_sv(CV* cv)
+
+=for hackers
+Found in file op.c
+
 =item dMARK
 
 Declare a stack marker variable, C<mark>, for the XSUB.  See C<MARK> and
@@ -1162,7 +1175,7 @@ Found in file handy.h
 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
 eligible for inlining at compile-time.
 
-       void    newCONSTSUB(HV* stash, char* name, SV* sv)
+       CV*     newCONSTSUB(HV* stash, char* name, SV* sv)
 
 =for hackers
 Found in file op.c

diff --git a/proto.h b/proto.h
index 59129b1..2713916 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -504,7 +504,7 @@ PERL_CALLCONV OP*   Perl_newANONHASH(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block);
 PERL_CALLCONV OP*      Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right);
 PERL_CALLCONV OP*      Perl_newCONDOP(pTHX_ I32 flags, OP* expr, OP* trueop, OP* falseop);
-PERL_CALLCONV void     Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv);
+PERL_CALLCONV CV*      Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv);
 PERL_CALLCONV void     Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
 PERL_CALLCONV OP*      Perl_newFOROP(pTHX_ I32 flags, char* label, line_t forline, OP* sclr, OP* expr, OP*block, OP*cont);
 PERL_CALLCONV OP*      Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP* left, OP* right);

diff --git a/sv.c b/sv.c
index b795b29..148c762 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2745,12 +2745,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                            if (!GvCVGEN((GV*)dstr) &&
                                (CvROOT(cv) || CvXSUB(cv)))
                            {
-                               SV *const_sv = cv_const_sv(cv);
-                               bool const_changed = TRUE;
-                               if(const_sv)
-                                   const_changed = sv_cmp(const_sv,
-                                          op_const_sv(CvSTART((CV*)sref),
-                                                      (CV*)sref));
+                               SV *const_sv;
                                /* ahem, death to those who redefine
                                 * active sort subs */
                                if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -2758,11 +2753,20 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                                    Perl_croak(aTHX_
                                    "Can't redefine active sort subroutine %s",
                                          GvENAME((GV*)dstr));
-                               if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
-                                   Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
-                                            "Constant subroutine %s redefined"
-                                            : "Subroutine %s redefined",
-                                            GvENAME((GV*)dstr));
+                               /* Redefining a sub - warning is mandatory if
+                                  it was a const and its value changed. */
+                               if (ckWARN(WARN_REDEFINE)
+                                   || (CvCONST(cv)
+                                       && (!CvCONST((CV*)sref)
+                                           || sv_cmp(cv_const_sv(cv),
+                                                     cv_const_sv((CV*)sref)))))
+                               {
+                                   Perl_warner(aTHX_ WARN_REDEFINE,
+                                       CvCONST(cv)
+                                       ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined", 
+                                       GvENAME((GV*)dstr));
+                               }
                            }
                            cv_ckproto(cv, (GV*)dstr,
                                       SvPOK(sref) ? SvPVX(sref) : Nullch);