From: Doug MacEachern Date: Sun, 18 Jun 2000 13:24:55 +0000 (-0700) Subject: Re: [PATCH] Re: Speeding up method lookups X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4f470f63ec19cae10190b8f3ed622153f261d3b1;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] Re: Speeding up method lookups Message-ID: p4raw-id: //depot/cfgperl@6267 --- diff --git a/MANIFEST b/MANIFEST index 6573182..4e32b90 100644 --- 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 diff --git a/embed.pl b/embed.pl index bf41a0a..8efb189 100755 --- 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 diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 36c7221..8401fea 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -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); diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 2b0f5c8..0732327 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -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 ) ) { diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index c921eb0..1a986eb 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -407,7 +407,7 @@ No checks against the filesystem are made. =cut -sub rel2abs($;$;) { +sub rel2abs($$;$;) { my ($self,$path,$base ) = @_; # Clean up $path diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index e59aa21..56b5506 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -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{/} ) ; diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index 5d3079e..bd21914 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -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 ) ) { diff --git a/lib/base.pm b/lib/base.pm index 3cb42f5..b8d210e 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -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 --- 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 --- 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 index 0000000..5e9b924 --- /dev/null +++ b/t/op/method2entersub.t @@ -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)); diff --git a/xsutils.c b/xsutils.c index b4161b0..7b21574 100644 --- 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 */