This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Re: Speeding up method lookups
authorDoug MacEachern <dougm@covalent.net>
Sun, 18 Jun 2000 13:24:55 +0000 (06:24 -0700)
committerJarkko Hietaniemi <jhi@iki.fi>
Thu, 29 Jun 2000 18:16:07 +0000 (18:16 +0000)
Message-ID: <Pine.LNX.4.10.10006181306031.397-100000@mojo.covalent.net>

p4raw-id: //depot/cfgperl@6267

12 files changed:
MANIFEST
embed.pl
lib/ExtUtils/Install.pm
lib/File/Spec/Mac.pm
lib/File/Spec/Unix.pm
lib/File/Spec/VMS.pm
lib/File/Spec/Win32.pm
lib/base.pm
op.c
perl.h
t/op/method2entersub.t [new file with mode: 0644]
xsutils.c

index 6573182..4e32b90 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1436,6 +1436,7 @@ t/op/local.t              See if local works
 t/op/lop.t             See if logical operators work
 t/op/magic.t           See if magic variables work
 t/op/method.t          See if method calls work
+t/op/method2entersub.t See if methods-to-entersubs works
 t/op/misc.t            See if miscellaneous bugs have been fixed
 t/op/mkdir.t           See if mkdir works
 t/op/my.t              See if lexical scoping works
index bf41a0a..8efb189 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2251,6 +2251,7 @@ s |char*  |gv_ename       |GV *gv
 s      |void   |cv_dump        |CV *cv
 s      |CV*    |cv_clone2      |CV *proto|CV *outside
 s      |bool   |scalar_mod_type|OP *o|I32 type
+s      |OP *   |method_2entersub|OP *o|OP *o2|OP *svop
 s      |OP *   |my_kid         |OP *o|OP *attrs
 s      |OP *   |dup_attrlist   |OP *o
 s      |void   |apply_attrs    |HV *stash|SV *target|OP *attrs
index 36c7221..8401fea 100644 (file)
@@ -40,7 +40,7 @@ sub install {
 
     my(%hash) = %$hash;
     my(%pack, $dir, $warn_permissions);
-    my($packlist) = ExtUtils::Packlist->new();
+    my($packlist) = ExtUtils::Packlist->new(undef);
     # -w doesn't work reliably on FAT dirs
     $warn_permissions++ if $^O eq 'MSWin32';
     local(*DIR);
index 2b0f5c8..0732327 100644 (file)
@@ -365,7 +365,7 @@ No checks against the filesystem are made.
 
 =cut
 
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
     my ($self,$path,$base ) = @_;
 
     if ( ! $self->file_name_is_absolute( $path ) ) {
index c921eb0..1a986eb 100644 (file)
@@ -407,7 +407,7 @@ No checks against the filesystem are made.
 
 =cut
 
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
     my ($self,$path,$base ) = @_;
 
     # Clean up $path
index e59aa21..56b5506 100644 (file)
@@ -437,7 +437,7 @@ Use VMS syntax when converting filespecs.
 
 =cut
 
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
     my $self = shift ;
     return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
         if ( join( '', @_ ) =~ m{/} ) ;
index 5d3079e..bd21914 100644 (file)
@@ -363,7 +363,7 @@ No checks against the filesystem are made.
 
 =cut
 
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
     my ($self,$path,$base ) = @_;
 
     if ( ! $self->file_name_is_absolute( $path ) ) {
index 3cb42f5..b8d210e 100644 (file)
@@ -52,14 +52,21 @@ sub import {
     my $fields_base;
     my $pkg = caller(0);
 
+    my @attrs;
+    my $isa = \@{"$pkg\::ISA"};
+
     foreach my $base (@_) {
+        if ($base =~ /^[-+]/) { #attribute
+            push @attrs, $base;
+            next;
+        }
        next if $pkg->isa($base);
-       push @{"$pkg\::ISA"}, $base;
+       push @$isa, $base;
        unless (exists ${"$base\::"}{VERSION}) {
            eval "require $base";
            # Only ignore "Can't locate" errors from our eval require.
            # Other fatal errors (syntax etc) must be reported.
-           die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+           die if $@ && $@ !~ /^Can\'t locate .*? at \(eval /;
            unless (%{"$base\::"}) {
                require Carp;
                Carp::croak("Base class package \"$base\" is empty.\n",
@@ -87,6 +94,10 @@ sub import {
        require fields;
        fields::inherit($pkg, $fields_base);
     }
+    if (@attrs) {
+        require attributes;
+        attributes::->import($pkg, $isa, @attrs);
+    }
 }
 
 1;
diff --git a/op.c b/op.c
index 3f71cfa..af7ca34 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6215,6 +6215,81 @@ Perl_ck_join(pTHX_ OP *o)
     return ck_fun(o);
 }
 
+STATIC OP *
+S_method_2entersub(pTHX_ OP *o, OP *o2, OP *svop)
+{
+    GV *gv;
+    SV *method = ((SVOP*)svop)->op_sv;
+    char *methname;
+    STRLEN methlen;
+    HV *stash;
+    OP *mop;
+
+    if (svop->op_type == OP_METHOD_NAMED) {
+        methname = SvPV(method, methlen);
+    }
+    else {
+        return Nullop;
+    }
+
+    if (o2->op_type == OP_CONST) {
+        STRLEN len;
+        char *package = SvPV(((SVOP*)o2)->op_sv, len);
+        stash = gv_stashpvn(package, len, FALSE);
+    }
+    else if (o2->op_type == OP_PADSV) {
+        /* my Dog $spot = shift; $spot->bark */
+        SV *sv = *av_fetch(PL_comppad_name, o2->op_targ, FALSE);
+        if (sv && SvOBJECT(sv)) {
+            stash = SvSTASH(sv);
+        }
+        else {
+            return Nullop;
+        }
+    }
+    else {
+        return Nullop;
+    }
+
+    /* -1 so cache globs are not created */
+    /* XXX: support SUPER:: and UNIVERSAL, but not AUTOLOAD */
+    if (!(stash && (gv = gv_fetchmeth(stash, methname, methlen, -1)) && 
+          isGV(gv))) {
+        return Nullop;
+    }
+
+    /* XXX: check entire @ISA tree for readonly-ness ? */
+    if (GvSTASH(CvGV(GvCV(gv))) != stash) {
+        GV **gvp, *isagv;
+        AV *av;
+        gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+        av = (gvp && (isagv = *gvp) && isagv != (GV*)&PL_sv_undef) ? 
+            GvAV(isagv) : Nullav;
+
+        if (isagv && av && !SvREADONLY((SV*)av)) {
+            return Nullop; /* @ISA is not frozen */
+        }
+
+        gv = CvGV(GvCV(gv)); /* point to the real gv */
+    }
+
+    if (o2->op_type == OP_CONST) {
+        /* remove bareword-ness of class name */
+        o2->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT); 
+    }
+
+    for (mop = o2; mop->op_sibling->op_sibling; mop = mop->op_sibling) ;
+
+    op_free(mop->op_sibling); /* loose OP_METHOD_NAMED */
+    mop->op_sibling = scalar(newUNOP(OP_RV2CV, 0,
+                                     newGVOP(OP_GV, 0, gv)));
+
+    ((cUNOPo->op_first->op_sibling)
+     ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first->op_sibling = o2;
+
+    return ck_subr(o);
+}
+
 OP *
 Perl_ck_subr(pTHX_ OP *o)
 {
@@ -6249,8 +6324,16 @@ Perl_ck_subr(pTHX_ OP *o)
        }
     }
     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
-       if (o2->op_type == OP_CONST)
+       if ((PL_hints & HINT_CT_MRESOLVE) && /* use base qw(... +readonly) */
+            (o2->op_type == OP_CONST || o2->op_type == OP_PADSV)) {
+            OP *nop;
+            if ((nop = method_2entersub(o, o2, cvop))) {
+                return nop;
+            }
+        }
+       if (o2->op_type == OP_CONST) {
            o2->op_private &= ~OPpCONST_STRICT;
+        }
        else if (o2->op_type == OP_LIST) {
            OP *o = ((UNOP*)o2)->op_first->op_sibling;
            if (o && o->op_type == OP_CONST)
diff --git a/perl.h b/perl.h
index 8064d9d..a195756 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2588,6 +2588,7 @@ enum {            /* pass one of these to get_vtbl */
 #define HINT_NEW_STRING                0x00008000
 #define HINT_NEW_RE            0x00010000
 #define HINT_LOCALIZE_HH       0x00020000 /* %^H needs to be copied */
+#define HINT_CT_MRESOLVE       0x00040000 /* resolve methods at compile time */
 
 #define HINT_RE_TAINT          0x00100000
 #define HINT_RE_EVAL           0x00200000
diff --git a/t/op/method2entersub.t b/t/op/method2entersub.t
new file mode 100644 (file)
index 0000000..5e9b924
--- /dev/null
@@ -0,0 +1,66 @@
+#!./perl
+
+BEGIN {
+    package BaseClass; #forward package declaration for base.pm
+
+    chdir 't' if -d 't';
+    unshift @INC, '../lib' if -d '../lib';
+}
+
+{
+    package BaseClass;
+
+    sub method {
+    }
+}
+
+{
+    package Class;
+    use base qw(BaseClass +readonly);
+
+    sub mtest {
+        Class->method;
+
+        my Class $obj = bless {};
+
+        $obj->method;
+    }
+
+}
+
+{
+    package Class2;
+    use base qw(BaseClass);
+
+    sub mtest {
+        Class2->method;
+
+        my Class2 $obj = bless {};
+
+        $obj->method;
+    }
+}
+
+use Test;
+
+plan tests => 2;
+
+use B ();
+
+sub cv_root {
+    B::svref_2object(shift)->ROOT;
+}
+
+sub method_in_tree {
+    my $op = shift;
+    if ($$op && ($op->flags & B::OPf_KIDS)) {
+       for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+            return 1 if $kid->ppaddr =~ /method/i;
+           return 1 if method_in_tree($kid);
+       }
+    }
+    return 0;
+}
+
+ok ! method_in_tree(cv_root(\&Class::mtest));
+ok   method_in_tree(cv_root(\&Class2::mtest));
index b4161b0..7b21574 100644 (file)
--- a/xsutils.c
+++ b/xsutils.c
@@ -48,7 +48,7 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
 
     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
        name = SvPV(attr, len);
-       if ((negated = (*name == '-'))) {
+       if ((negated = (*name == '-')) || (*name == '+')) {
            name++;
            len--;
        }
@@ -87,6 +87,34 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
                }
                break;
            }
+          case SVt_IV:
+          case SVt_NV:
+          case SVt_PV:
+          case SVt_PVIV:
+          case SVt_PVNV:
+          case SVt_PVAV:
+          case SVt_PVHV:
+           switch ((int)len) {
+              case 8:
+               switch (*name) {
+                  case 'r':
+                    if (strEQ(name, "readonly")) {
+                       if (negated)
+                           SvREADONLY_off(sv);
+                       else
+                           SvREADONLY_on(sv);
+                        if (SvTYPE(sv) == SVt_PVAV && SvMAGIC(sv)
+                            && mg_find(sv, 'I')) { /* @ISA */
+                            if (negated)
+                                PL_hints &= ~HINT_CT_MRESOLVE;
+                            else
+                                PL_hints |= HINT_CT_MRESOLVE;
+                        }
+                       continue;
+                    }
+                    break;
+                }
+            }
            break;
        default:
            /* nothing, yet */