Integrate:

[ 26461]
Subject: [PATCH] Speed up Perl_sv_derived_from
From: Andy Lester <andy@petdance.com>
Message-ID: <20051222220044.GH4370@petdance.com>
Date: Thu, 22 Dec 2005 16:00:44 -0600

[ 26477]
For the rare case of EMFILE during require, save object code space
by using newSVpvf
(Would it be worth using it for all require failures?)

[ 26500]
Refactor the require failure message generation to use 1 less temporary
SV, and to build as much text as possible with newSVpvf

[ 26503]
gv_fetch_flags in newATTRSUB can actually be const.
Comment the logic behind the terms in the ternary that chooses the
flags value.

[ 26517]
As the backreferences AV doesn't hold references on its contents,
surely it should have AvREAL turned off?

[ 26534]
Reduce size of buffers for identifier names, as suggested in

Subject: Stack usage (in gv_stashpvn and others)
From: Tels <nospam-abuse@bloodgate.com>
Date: Thu, 29 Dec 2005 18:40:49 +0100
Message-Id: <200512291840.50765@bloodgate.com>

[ 26541]
Now that the backreference array has no NULL entries, and is correctly
marked as AvREAL_off(), there's no reason not to use sv_dup to clone
it.

[ 26544]
Tweak S_init_main_stash so as allocate PL_curstname as a shared string
scalar, and hence avoid thrashing the shared string table for "main".

[ 26550]
Remove unneeded test in Perl_hv_clear_placeholders.
Rejig S_hfreeentries to a double loop, which is clearer and smaller.

[ 26552]
Turn a for loop that's almost a while into an honest-to-goodness while.
p4raw-link: @26552 on //depot/perl: cf6db12b45410d62d1d8568c336c79f938bf3310
p4raw-link: @26550 on //depot/perl: 7440661e2628bf13f68b1828cf423db52f268294
p4raw-link: @26544 on //depot/perl: 23579a14417118b3085c688fa8e8359c0d0a93ba
p4raw-link: @26541 on //depot/perl: d7cbc7b5c258cffaf362ecafb36c5dfc354c1ffa
p4raw-link: @26534 on //depot/perl: 0cea005841294e1c066737aa1ee9f5a7235bc7bc
p4raw-link: @26517 on //depot/perl: e3d998840fa41946cf8ee609337ef4edea761fd2
p4raw-link: @26503 on //depot/perl: b48b272aa95a2266df9fecc3e1bbd0e34ff4d9ae
p4raw-link: @26500 on //depot/perl: b8f04b1b779ce1dfdaee8f5444dc413afe3e9866
p4raw-link: @26477 on //depot/perl: b9b739dc8249ced77343a7411d1a5714224db0f8
p4raw-link: @26461 on //depot/perl: 0b6f4f5cb8bbeb6c5d1eb714dbf6cdf58c5516d7

p4raw-id: //depot/maint-5.8/perl@29789
p4raw-edited: from //depot/perl@26552 'edit in' hv.c (@26551..)
p4raw-integrated: from //depot/perl@26544 'merge in' perl.c (@26535..)
p4raw-edited: from //depot/perl@26534 'edit in' gv.c (@26532..)
p4raw-integrated: from //depot/perl@26517 'edit in' sv.c (@26505..)
p4raw-integrated: from //depot/perl@26503 'merge in' op.c (@26494..)
p4raw-integrated: from //depot/perl@26477 'edit in' pp_ctl.c (@26450..)
p4raw-integrated: from //depot/perl@26461 'merge in' universal.c
	(@26450..)

diff --git a/gv.c b/gv.c
index e5f4a4c..7deeec8 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -208,7 +208,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        ENTER;
        if (has_constant) {
            /* newCONSTSUB takes ownership of the reference from us.  */
-           GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+           GvCV(gv) = newCONSTSUB(stash, (char *)name, has_constant);
        } else {
            /* XXX unsafe for threads if eval_owner isn't held */
            (void) start_subparse(0,0); /* Create empty CV in compcv. */
@@ -693,7 +693,7 @@ package does not exist then NULL is returned.
 HV*
 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 {
-    char smallbuf[256];
+    char smallbuf[128];
     char *tmpbuf;
     HV *stash;
     GV *tmpgv;
@@ -783,7 +783,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
            len = name_cursor - name;
            if (len > 0) {
-               char smallbuf[256];
+               char smallbuf[128];
                char *tmpbuf;
 
                if (len + 3 < sizeof (smallbuf))

diff --git a/hv.c b/hv.c
index db6540e..f537f30 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1531,12 +1531,9 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv)
        /* Loop down the linked list heads  */
        bool first = 1;
        HE **oentry = &(HvARRAY(hv))[i];
-       HE *entry = *oentry;
-
-       if (!entry)
-           continue;
+       HE *entry;
 
-       for (; entry; entry = *oentry) {
+       while ((entry = *oentry)) {
            if (HeVAL(entry) == &PL_sv_placeholder) {
                *oentry = HeNEXT(entry);
                if (first && !*oentry)
@@ -1569,16 +1566,13 @@ STATIC void
 S_hfreeentries(pTHX_ HV *hv)
 {
     register HE **array;
-    register HE *entry;
-    I32 riter;
-    I32 max;
+    I32 i;
 
 
     if (!HvARRAY(hv))
        return;
 
-    riter = 0;
-    max = HvMAX(hv);
+    i = HvMAX(hv);
     array = HvARRAY(hv);
     /* make everyone else think the array is empty, so that the destructors
      * called for freed entries can't recusively mess with us */
@@ -1586,19 +1580,17 @@ S_hfreeentries(pTHX_ HV *hv)
     HvFILL(hv) = 0;
     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
 
-    entry = array[0];
-    for (;;) {
-       if (entry) {
+    do {
+       /* Loop down the linked list heads  */
+       HE *entry = array[i];
+
+       while (entry) {
            register HE * const oentry = entry;
            entry = HeNEXT(entry);
            hv_free_ent(hv, oentry);
        }
-       if (!entry) {
-           if (++riter > max)
-               break;
-           entry = array[riter];
-       }
-    }
+    } while (--i >= 0);
+
     HvARRAY(hv) = array;
     (void)hv_iterinit(hv);
 }

diff --git a/op.c b/op.c
index e2c7e61..1cac060 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4330,8 +4330,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     STRLEN ps_len;
     register CV *cv = NULL;
     SV *const_sv;
-    I32 gv_fetch_flags;
-
+    /* 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
+       store it.  */
+    const I32 gv_fetch_flags
+       = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
+       ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
 
     if (proto) {
@@ -4352,8 +4358,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        aname = NULL;
 
     /* There may be future conflict here as change 23766 is not yet merged.  */
-    gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
-       ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
        : gv_fetchpv(aname ? aname
                     : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),

diff --git a/perl.c b/perl.c
index dbba823..4f6df76 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3579,12 +3579,19 @@ S_init_main_stash(pTHX)
     GV *gv;
 
     PL_curstash = PL_defstash = newHV();
-    PL_curstname = newSVpvn("main",4);
+    /* We know that the string "main" will be in the global shared string
+       table, so it's a small saving to use it rather than allocate another
+       8 bytes.  */
+    PL_curstname = newSVpvn_share("main", 4, 0);
     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
+    /* If we hadn't caused another reference to "main" to be in the shared
+       string table above, then it would be worth reordering these two,
+       because otherwise all we do is delete "main" from it as a consequence
+       of the SvREFCNT_dec, only to add it again with hv_name_set */
     SvREFCNT_dec(GvHV(gv));
+    hv_name_set(PL_defstash, "main", 4, 0);
     GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
     SvREADONLY_on(gv);
-    hv_name_set(PL_defstash, "main", 4, 0);
     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
     GvMULTI_on(PL_incgv);
     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */

diff --git a/pp_ctl.c b/pp_ctl.c
index 81d7271..7ee8344 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3297,29 +3297,28 @@ PP(pp_require)
        if (PL_op->op_type == OP_REQUIRE) {
            const char *msgstr = name;
            if(errno == EMFILE) {
-               SV * const msg = sv_2mortal(newSVpv(msgstr,0));
-               sv_catpv(msg, ":  "); 
-               sv_catpv(msg, Strerror(errno));
+               SV * const msg
+                   = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
+                                              Strerror(errno)));
                msgstr = SvPV_nolen_const(msg);
            } else {
                if (namesv) {                   /* did we lookup @INC? */
-                   SV * const msg = sv_2mortal(newSVpv(msgstr,0));
-                   SV * const dirmsgsv = NEWSV(0, 0);
                    AV * const ar = GvAVn(PL_incgv);
                    I32 i;
-                   sv_catpvn(msg, " in @INC", 8);
-                   if (instr(SvPVX_const(msg), ".h "))
-                       sv_catpv(msg, " (change .h to .ph maybe?)");
-                   if (instr(SvPVX_const(msg), ".ph "))
-                       sv_catpv(msg, " (did you run h2ph?)");
-                   sv_catpv(msg, " (@INC contains:");
+                   SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_ 
+                       "%s in @INC%s%s (@INC contains:",
+                       msgstr,
+                       (instr(msgstr, ".h ")
+                        ? " (change .h to .ph maybe?)" : ""),
+                       (instr(msgstr, ".ph ")
+                        ? " (did you run h2ph?)" : "")
+                                                             ));
+                   
                    for (i = 0; i <= AvFILL(ar); i++) {
-                       const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
-                       Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
-                       sv_catsv(msg, dirmsgsv);
+                       sv_catpvn(msg, " ", 1);
+                       sv_catsv(msg, *av_fetch(ar, i, TRUE));
                    }
                    sv_catpvn(msg, ")", 1);
-                   SvREFCNT_dec(dirmsgsv);
                    msgstr = SvPV_nolen_const(msg);
                }    
            }

diff --git a/sv.c b/sv.c
index 76f2b13..57e8348 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4103,6 +4103,7 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
        av = (AV*)mg->mg_obj;
     else {
        av = newAV();
+       AvREAL_off(av);
        sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
        /* av now has a refcnt of 2, which avoids it getting freed
         * before us during global cleanup. The extra ref is removed
@@ -8881,15 +8882,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
            nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
        }
        else if(mg->mg_type == PERL_MAGIC_backref) {
-           const AV * const av = (AV*) mg->mg_obj;
-           SV **svp;
-           I32 i;
-           (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
-           svp = AvARRAY(av);
-           for (i = AvFILLp(av); i >= 0; i--) {
-               if (!svp[i]) continue;
-               av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
-           }
+           /* The backref AV has its reference count deliberately bumped by
+              1.  */
+           nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
        }
        else {
            nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)

diff --git a/universal.c b/universal.c
index 6be8fdb..5745145 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -140,29 +140,29 @@ for class names as well as for objects.
 bool
 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
-    const char *type = NULL;
-    HV *stash = NULL;
-    HV *name_stash;
+    HV *stash;
 
     SvGETMAGIC(sv);
 
     if (SvROK(sv)) {
+       const char *type;
         sv = SvRV(sv);
         type = sv_reftype(sv,0);
-        if (SvOBJECT(sv))
-            stash = SvSTASH(sv);
+       if (type && strEQ(type,name))
+           return TRUE;
+       stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
     }
     else {
         stash = gv_stashsv(sv, FALSE);
     }
 
-    name_stash = gv_stashpv(name, FALSE);
+    if (stash) {
+       HV * const name_stash = gv_stashpv(name, FALSE);
+       return isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes;
+    }
+    else
+       return FALSE;
 
-    return (type && strEQ(type,name)) ||
-            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
-             == &PL_sv_yes)
-        ? TRUE
-        : FALSE ;
 }
 
 #include "XSUB.h"