diff --git a/AUTHORS b/AUTHORS index 9db941ec0c41..e48bc3935b29 100644 --- a/AUTHORS +++ b/AUTHORS @@ -886,6 +886,7 @@ Offer Kaye Olaf Flebbe Olaf Titz Oleg Nesterov +Oleg Pronin Olivier Blin Olli Savia Ollivier Robert diff --git a/MANIFEST b/MANIFEST index 1bb915fa85c4..4dd6717de105 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3884,6 +3884,7 @@ haiku/Haiku/Haiku.xs Haiku extension external subroutines haiku/haikuish.h Header for the Haiku port haiku/Haiku/Makefile.PL Haiku extension makefile writer handy.h Handy definitions +hashmap.h Hashmap implementation hints/aix_3.sh Hints for named architecture hints/aix_4.sh Hints for named architecture hints/aix.sh Hints for named architecture diff --git a/dump.c b/dump.c index d15aee64a3b4..2bdfd7a5e311 100644 --- a/dump.c +++ b/dump.c @@ -1084,6 +1084,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) case OP_CONST: case OP_HINTSEVAL: case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: #ifndef USE_ITHREADS /* with ITHREADS, consts are stored in the pad, and the right pad * may not be active here, so skip */ @@ -1776,9 +1778,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (SvMAGIC(sv)) do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); } - if (SvSTASH(sv)) + if (SvSTASH(sv) && !(type == SVt_PVHV && HvNAME(sv))) /* dont dump stash on stashes (they have destructor CV* addr there) */ do_hv_dump(level, file, " STASH", SvSTASH(sv)); - if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv)); } @@ -2495,7 +2496,6 @@ Perl_debprofdump(pTHX) } } - /* * Local variables: * c-indentation-style: bsd diff --git a/embed.fnc b/embed.fnc index 90c56ed5ada0..20f7af564f26 100644 --- a/embed.fnc +++ b/embed.fnc @@ -511,6 +511,7 @@ Apd |GV* |gv_fetchmeth_pv |NULLOK HV* stash|NN const char* name \ |I32 level|U32 flags Apd |GV* |gv_fetchmeth_pvn |NULLOK HV* stash|NN const char* name \ |STRLEN len|I32 level|U32 flags +Apd |GV* |gv_fetchmeth_ent |NULLOK HV* stash|NN const SVMAP_ENT* entry|I32 level|U32 flags Amd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash \ |NN const char* name|STRLEN len \ |I32 level @@ -525,8 +526,8 @@ Apd |GV* |gv_fetchmethod_autoload|NN HV* stash|NN const char* name \ ApM |GV* |gv_fetchmethod_sv_flags|NN HV* stash|NN SV* namesv|U32 flags ApM |GV* |gv_fetchmethod_pv_flags|NN HV* stash|NN const char* name \ |U32 flags -ApM |GV* |gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name \ - |const STRLEN len|U32 flags +ApM |GV* |gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name|STRLEN len|U32 flags +ApM |GV* |gv_fetchmethod_ent|NN HV* stash|NN const SVMAP_ENT* entry|U32 flags Ap |GV* |gv_fetchpv |NN const char *nambeg|I32 add|const svtype sv_type Ap |void |gv_fullname |NN SV* sv|NN const GV* gv Apmb |void |gv_fullname3 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix @@ -547,8 +548,16 @@ px |GV * |gv_override |NN const char * const name \ |const STRLEN len XMpd |void |gv_try_downgrade|NN GV* gv Apd |HV* |gv_stashpv |NN const char* name|I32 flags -Apd |HV* |gv_stashpvn |NN const char* name|U32 namelen|I32 flags +Apd |HV* |gv_stashpvn |NN const char* name|STRLEN namelen|I32 flags +Apd |HV* |gv_stashent |NN const SVMAP_ENT* entry|I32 flags +Apd |void |gv_stashpvn_cache_invalidate |NN const char* name|STRLEN namelen|I32 flags +Apd |void |gv_stashsv_cache_invalidate |NN SV* sv +Apd |void |gv_stash_cache_invalidate +Apd |void |gv_stash_cache_init +Apd |void |gv_stash_cache_destroy Apd |HV* |gv_stashsv |NN SV* sv|I32 flags +Ap |HV* |curmethod_stash|NN SV** objptr|NULLOK CV* sub +Ap |HV* |method_stash |NN SV** objptr|NULLOK SV* meth Apd |void |hv_clear |NULLOK HV *hv : used in SAVEHINTS() and op.c ApdR |HV * |hv_copy_hints_hv|NULLOK HV *const ohv @@ -1017,6 +1026,8 @@ Apd |SV* |newSVrv |NN SV *const rv|NULLOK const char *const classname Apda |SV* |newSVsv |NULLOK SV *const old Apda |SV* |newSV_type |const svtype type Apda |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first +Apda |OP* |newMETHOP |I32 type|I32 flags|NULLOK OP* dynamic_meth +Apda |OP* |newMETHOPnamed|I32 type|I32 flags|NN SV* const_meth Apda |OP* |newWHENOP |NULLOK OP* cond|NN OP* block Apda |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \ |NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \ @@ -2041,7 +2052,7 @@ s |OP* |do_smartmatch |NULLOK HV* seen_this \ #if defined(PERL_IN_PP_HOT_C) s |void |do_oddball |NN SV **oddkey|NN SV **firstkey -sR |SV* |method_common |NN SV* meth|NULLOK U32* hashp +sR |HV* |opmethod_stash |NN METHOP* op|NN SV* meth #endif #if defined(PERL_IN_PP_SORT_C) @@ -2598,6 +2609,7 @@ sMd |SV* |find_uninit_var|NULLOK const OP *const obase \ |NULLOK const SV *const uninit_sv|bool top #endif +Ap |HV* |gv_stashof_pvn|NN const char *name|STRLEN len|I32 flags|const svtype sv_type|NULLOK const char** name_ret|NULLOK STRLEN *len_ret|NULLOK GV** gv_ret Ap |GV* |gv_fetchpvn_flags|NN const char* name|STRLEN len|I32 flags|const svtype sv_type Ap |GV* |gv_fetchsv|NN SV *name|I32 flags|const svtype sv_type @@ -2696,6 +2708,7 @@ s |void |mro_gather_and_rename|NN HV * const stashes \ pd |void |mro_isa_changed_in|NN HV* stash Apd |void |mro_method_changed_in |NN HV* stash pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK HV * const oldstash|NN const GV * const gv|U32 flags +Ap |void |mro_global_method_cache_clear : Only used in perl.c p |void |boot_core_mro Apon |void |sys_init |NN int* argc|NN char*** argv diff --git a/embed.h b/embed.h index 7ca719dac4de..aa5423aa3cbd 100644 --- a/embed.h +++ b/embed.h @@ -95,6 +95,7 @@ #define croak_no_modify Perl_croak_no_modify #define croak_sv(a) Perl_croak_sv(aTHX_ a) #define croak_xs_usage Perl_croak_xs_usage +#define curmethod_stash(a,b) Perl_curmethod_stash(aTHX_ a,b) #define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a) #define custom_op_name(a) Perl_custom_op_name(aTHX_ a) #define cv_clone(a) Perl_cv_clone(aTHX_ a) @@ -188,6 +189,7 @@ #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) #define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c) +#define gv_fetchmeth_ent(a,b,c,d) Perl_gv_fetchmeth_ent(aTHX_ a,b,c,d) #define gv_fetchmeth_pv(a,b,c,d) Perl_gv_fetchmeth_pv(aTHX_ a,b,c,d) #define gv_fetchmeth_pv_autoload(a,b,c,d) Perl_gv_fetchmeth_pv_autoload(aTHX_ a,b,c,d) #define gv_fetchmeth_pvn(a,b,c,d,e) Perl_gv_fetchmeth_pvn(aTHX_ a,b,c,d,e) @@ -195,6 +197,7 @@ #define gv_fetchmeth_sv(a,b,c,d) Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d) #define gv_fetchmeth_sv_autoload(a,b,c,d) Perl_gv_fetchmeth_sv_autoload(aTHX_ a,b,c,d) #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c) +#define gv_fetchmethod_ent(a,b,c) Perl_gv_fetchmethod_ent(aTHX_ a,b,c) #define gv_fetchmethod_pv_flags(a,b,c) Perl_gv_fetchmethod_pv_flags(aTHX_ a,b,c) #define gv_fetchmethod_pvn_flags(a,b,c,d) Perl_gv_fetchmethod_pvn_flags(aTHX_ a,b,c,d) #define gv_fetchmethod_sv_flags(a,b,c) Perl_gv_fetchmethod_sv_flags(aTHX_ a,b,c) @@ -208,9 +211,16 @@ #define gv_init_pvn(a,b,c,d,e) Perl_gv_init_pvn(aTHX_ a,b,c,d,e) #define gv_init_sv(a,b,c,d) Perl_gv_init_sv(aTHX_ a,b,c,d) #define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d) +#define gv_stash_cache_destroy() Perl_gv_stash_cache_destroy(aTHX) +#define gv_stash_cache_init() Perl_gv_stash_cache_init(aTHX) +#define gv_stash_cache_invalidate() Perl_gv_stash_cache_invalidate(aTHX) +#define gv_stashent(a,b) Perl_gv_stashent(aTHX_ a,b) +#define gv_stashof_pvn(a,b,c,d,e,f,g) Perl_gv_stashof_pvn(aTHX_ a,b,c,d,e,f,g) #define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) #define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) +#define gv_stashpvn_cache_invalidate(a,b,c) Perl_gv_stashpvn_cache_invalidate(aTHX_ a,b,c) #define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b) +#define gv_stashsv_cache_invalidate(a) Perl_gv_stashsv_cache_invalidate(aTHX_ a) #define hv_clear(a) Perl_hv_clear(aTHX_ a) #define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a) #define hv_common(a,b,c,d,e,f,g,h) Perl_hv_common(aTHX_ a,b,c,d,e,f,g,h) @@ -317,6 +327,7 @@ #define mess Perl_mess #endif #define mess_sv(a,b) Perl_mess_sv(aTHX_ a,b) +#define method_stash(a,b) Perl_method_stash(aTHX_ a,b) #define mg_clear(a) Perl_mg_clear(aTHX_ a) #define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d) #define mg_find Perl_mg_find @@ -331,6 +342,7 @@ #define mini_mktime Perl_mini_mktime #define moreswitches(a) Perl_moreswitches(aTHX_ a) #define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a) +#define mro_global_method_cache_clear() Perl_mro_global_method_cache_clear(aTHX) #define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a) #define my_atof(a) Perl_my_atof(aTHX_ a) #define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b) @@ -367,6 +379,8 @@ #define newLOGOP(a,b,c,d) Perl_newLOGOP(aTHX_ a,b,c,d) #define newLOOPEX(a,b) Perl_newLOOPEX(aTHX_ a,b) #define newLOOPOP(a,b,c,d) Perl_newLOOPOP(aTHX_ a,b,c,d) +#define newMETHOP(a,b,c) Perl_newMETHOP(aTHX_ a,b,c) +#define newMETHOPnamed(a,b,c) Perl_newMETHOPnamed(aTHX_ a,b,c) #define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e) #define newNULLLIST() Perl_newNULLLIST(aTHX) #define newOP(a,b) Perl_newOP(aTHX_ a,b) @@ -1585,7 +1599,7 @@ # endif # if defined(PERL_IN_PP_HOT_C) #define do_oddball(a,b) S_do_oddball(aTHX_ a,b) -#define method_common(a,b) S_method_common(aTHX_ a,b) +#define opmethod_stash(a,b) S_opmethod_stash(aTHX_ a,b) # endif # if defined(PERL_IN_PP_PACK_C) #define bytes_to_uni S_bytes_to_uni diff --git a/embedvar.h b/embedvar.h index 454c1ee49bc4..a869aef70e25 100644 --- a/embedvar.h +++ b/embedvar.h @@ -192,6 +192,7 @@ #define PL_maxsysfd (vTHX->Imaxsysfd) #define PL_memory_debug_header (vTHX->Imemory_debug_header) #define PL_mess_sv (vTHX->Imess_sv) +#define PL_methstash (vTHX->Imethstash) #define PL_min_intro_pending (vTHX->Imin_intro_pending) #define PL_minus_E (vTHX->Iminus_E) #define PL_minus_F (vTHX->Iminus_F) diff --git a/ext/B/B.xs b/ext/B/B.xs index a130ad3cb455..865f1fa9c7ed 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1259,6 +1259,38 @@ oplist(o) SP = oplist(aTHX_ o, SP); +MODULE = B PACKAGE = B::SVOP + +void +class_sv (o) + B::SVOP o +ALIAS: + rclass_sv = 1 + class_targ = 2 + rclass_targ = 3 +PPCODE: + SV* sv; + if (o->op_type != OP_METHOD && o->op_type != OP_METHOD_NAMED && o->op_type != OP_METHOD_SUPER && + o->op_type != OP_METHOD_REDIR) + croak("B::SVOP::const_* : wrong op_type"); + switch (ix) { + case 0: + if (!cMETHOPx(o)->op_class_hash) XSRETURN_UNDEF; + sv = cMETHOPx(o)->op_class_sv; + break; + case 1: + if (o->op_type != OP_METHOD_REDIR) croak("B::SVOP::const_rclass: wrong op_type"); + sv = cMETHOPx(o)->op_rclass_sv; + break; + case 2: + XSRETURN_UV(cMETHOPx(o)->op_class_targ); + case 3: + XSRETURN_UV(cMETHOPx(o)->op_rclass_targ); + } + ST(0) = make_sv_object(aTHX_ sv); + XSRETURN(1); + + MODULE = B PACKAGE = B::SV #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 6c818a4e463a..dc6a7d81ef88 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "0.992"; +our $VERSION = "0.993"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -659,6 +659,7 @@ $priv{$_}{128} = "+1" for qw(caller wantarray runcv); @{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK); $priv{$_}{128} = "UTF" for qw(last redo next goto dump); $priv{split}{128} = "IMPLIM"; +$priv{method_redir}{1} = "SUPER"; our %hints; # used to display each COP's op_hints values @@ -892,7 +893,7 @@ sub concise_op { elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix; - my $preferpv = $h{name} eq "method_named"; + my $preferpv = ($h{name} =~ /^method_/) ? 1 : 0; if ($h{class} eq "PADOP" or !${$op->sv}) { my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]"; diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index ca82cbd877f8..6db5b00ae47f 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -176,6 +176,7 @@ my $testpkgs = { OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (), $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (), + $] >= 5.020 ? qw(OPpMETHOD_SUPER) : (), 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10 ], }, diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index a48b01d30693..098754bbbabf 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.27"; +$VERSION = "1.28"; use Carp; use Exporter (); @@ -339,7 +339,8 @@ invert_opset function. rv2cv anoncode prototype coreargs - entersub leavesub leavesublv return method method_named + entersub leavesub leavesublv return method method_named method_super + method_redir -- XXX loops via recursion? leaveeval -- needed for Safe to operate, is safe diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 386dddf508d0..fef4510448dd 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -312,13 +312,16 @@ PPCODE: /* Invalidate ISA and method caches */ ++PL_sub_generation; - hv_clear(PL_stashcache); + gv_stash_cache_invalidate(); PUSHMARK(SP); perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ sv_free( (SV *) dummy_hv); /* get rid of what save_hash gave us*/ SPAGAIN; /* for the PUTBACK added by xsubpp */ LEAVE; + + ++PL_sub_generation; + gv_stash_cache_invalidate(); int diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t index 9f6e884a112a..d3f2cc7bbc10 100644 --- a/ext/XS-APItest/t/gv_fetchmeth.t +++ b/ext/XS-APItest/t/gv_fetchmeth.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 40; +use Test::More tests => 36; use_ok('XS::APItest'); @@ -24,7 +24,8 @@ for my $type ( 0..3 ) { ok !$::{$meth}, "...and doesn't vivify the glob."; ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false."; - ok $::{$meth}, "...but does vivify the glob."; + # commented out - perl no longer stores it's method cache in stash's HV + #ok $::{$meth}, "...but does vivify the glob."; } { diff --git a/ext/XS-APItest/t/gv_fetchmeth_autoload.t b/ext/XS-APItest/t/gv_fetchmeth_autoload.t index b24bfb1e1576..5c0d7a6a2490 100644 --- a/ext/XS-APItest/t/gv_fetchmeth_autoload.t +++ b/ext/XS-APItest/t/gv_fetchmeth_autoload.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 53; +use Test::More tests => 49; use_ok('XS::APItest'); @@ -30,7 +30,8 @@ for my $type ( 0..3 ) { ok !$::{$meth}, "...and doesn't vivify the glob."; ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false."; - ok $::{$meth}, "...but does vivify the glob."; + # commented out - perl no longer stores it's method cache in stash's HV + #ok $::{$meth}, "...but does vivify the glob."; ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "$types[$type] fails when the glob doesn't exist and AUTOLOAD is undefined,"; local *AUTOLOAD = sub { 1 }; diff --git a/gv.c b/gv.c index 8b43d91ef836..713365a4a5c8 100644 --- a/gv.c +++ b/gv.c @@ -40,6 +40,7 @@ Perl stores its global variables. static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; +static const SVMAP_ENT S_autoent = {{NULL}, 1546734242339941525, S_autoload, sizeof(S_autoload)-1, 0}; GV * Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) @@ -640,162 +641,196 @@ obtained from the GV with the C macro. /* NOTE: No support for tied ISA */ -GV * -Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) -{ +GV* +Perl_gv_fetchmeth_ent (pTHX_ HV *stash, const SVMAP_ENT* entry, I32 level, U32 flags) { GV** gvp; AV* linear_av; SV** linear_svp; SV* linear_sv; - HV* cstash, *cachestash; + HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; - GV* topgv = NULL; + U32 cachegen; + GV* cachegv = NULL; const char *hvname; - I32 create = (level >= 0) ? 1 : 0; I32 items; - U32 topgen_cmp; - U32 is_utf8 = flags & SVf_UTF8; + struct mro_meta* meta; + SVMAP* method_cache; + SVMAP_ENT* cache_found; + U32 is_utf8; + int i; + const char* name; + STRLEN len; - PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; + PERL_ARGS_ASSERT_GV_FETCHMETH_ENT; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - create = 0; /* probably appropriate */ - if(!(stash = gv_stashpvs("UNIVERSAL", 0))) - return 0; + level = -2; /* probably appropriate */ + if (!(stash = gv_stashpvs("UNIVERSAL", 0))) return 0; } - assert(stash); - hvname = HvNAME_get(stash); - if (!hvname) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - assert(hvname); - assert(name); + assert(entry->name); DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", - flags & GV_SUPER ? "SUPER " : "",name,hvname) ); + flags & GV_SUPER ? "SUPER " : "",entry->name,hvname) ); - topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; + meta = HvMROMETA(stash); + cachegen = meta->cache_gen + meta->pkg_gen + PL_sub_generation; if (flags & GV_SUPER) { - if (!HvAUX(stash)->xhv_mro_meta->super) - HvAUX(stash)->xhv_mro_meta->super = newHV(); - cachestash = HvAUX(stash)->xhv_mro_meta->super; + if (!meta->mro_supermethod) { + Newx(meta->mro_supermethod, 1, SVMAP); + svmap_new(meta->mro_supermethod); + } + method_cache = meta->mro_supermethod; + } + else { + if (!meta->mro_method) { + Newx(meta->mro_method, 1, SVMAP); + svmap_new(meta->mro_method); + } + method_cache = meta->mro_method; } - else cachestash = stash; /* check locally for a real method or a cache entry */ - gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len, - create); - if(gvp) { - topgv = *gvp; - have_gv: - assert(topgv); - if (SvTYPE(topgv) != SVt_PVGV) - gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8); - if ((cand_cv = GvCV(topgv))) { + + if ((cache_found = svmap_find(method_cache, entry))) { + cachegv = cache_found->value.gv; + assert(cachegv); + have_gv: + if ((cand_cv = GvCV(cachegv))) { /* If genuine method or valid cache entry, use it */ - if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { - return topgv; - } - else { - /* stale cache entry, junk it and move on */ - SvREFCNT_dec_NN(cand_cv); - GvCV_set(topgv, NULL); - cand_cv = NULL; - GvCVGEN(topgv) = 0; + if (GvCVGEN(cachegv) == cachegen) return cachegv; + else { /* stale cache entry, junk it and move on */ + SvREFCNT_dec_NN(cand_cv); + GvCV_set(cachegv, NULL); + cand_cv = NULL; + GvCVGEN(cachegv) = 0; } } - else if (GvCVGEN(topgv) == topgen_cmp) { - /* cache indicates no such method definitively */ - return 0; + else if (GvCVGEN(cachegv) == cachegen) return 0; /* cache indicates no such method definitively */ + else if (!(flags & GV_SUPER) && entry->len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 + && strnEQ(hvname, "CORE", 4) && S_maybe_add_coresub(aTHX_ NULL,cachegv,entry->name,entry->len)) + goto have_gv; + } + else if (level >= 0) { + /* store with shared string to prevent memNE compare for further calls and avoid name free() */ + U32 shash; + HEK* shek = share_hek(entry->name, (entry->flags & SVf_UTF8) ? -entry->len : entry->len, + PERL_HASH(shash, entry->name, entry->len)); + SVMAP_ENT putent = { + {NULL}, PERL_HASH64(HEK_KEY(shek), HEK_LEN(shek)), HEK_KEY(shek), HEK_LEN(shek), + HEK_UTF8(shek) ? SVf_UTF8 : 0 + }; + cachegv = (GV*)newSV(0); + gv_init_pvn(cachegv, stash, entry->name, entry->len, GV_ADDMULTI|(entry->flags & SVf_UTF8)); + GvCV_set(cachegv, NULL); + putent.value.gv = cachegv; + svmap_put(method_cache, &putent, HMDR_FIND); + + /* as the old code stored cache right in stash's HV, some poorly written code (version::vpp for example) relies on + * that if package exists it's stash is not empty (contains cached call to VERSION for example). So to be backward + * compatible we have to ensure that stash has at least one entry, otherwise put a fake entry into it. + */ + if (!HvUSEDKEYS(stash)) { + GV* fakegv = (GV*)newSV(0); + gv_init_pvn(fakegv, stash, "[cache]", 7, GV_ADDMULTI); + hv_store(stash, "[cache]", 7, (SV*)fakegv, 0); } - else if (stash == cachestash - && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 - && strnEQ(hvname, "CORE", 4) - && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) - goto have_gv; } - linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ - linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ - items = AvFILLp(linear_av); /* no +1, to skip over self */ - while (items--) { - linear_sv = *linear_svp++; - assert(linear_sv); - cstash = gv_stashsv(linear_sv, 0); + name = entry->name; + len = entry->len; + is_utf8 = entry->flags & SVf_UTF8; + + linear_av = NULL; + linear_svp = NULL; + items = 0; + i = (flags & GV_SUPER) ? 1 : 0; + + for (;;++i) { + if (i == 0) cstash = stash; + else { + if (!linear_av) { + linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ + linear_svp = AvARRAY(linear_av) + 1; /* second elem */ + items = AvFILLp(linear_av) + 1; + } + if (i >= items) break; + linear_sv = *linear_svp++; + assert(linear_sv); + cstash = gv_stashsv(linear_sv, 0); + } if (!cstash) { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%"HEKf"::ISA", - SVfARG(linear_sv), - HEKfARG(HvNAME_HEK(stash))); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%"HEKf"::ISA", SVfARG(linear_sv), HEKfARG(HvNAME_HEK(stash))); continue; } - assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); + if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); - if (strnEQ(hvname, "CORE", 4) - && (candidate = - S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) - )) + if (strnEQ(hvname, "CORE", 4) && (candidate = S_maybe_add_coresub(aTHX_ cstash,NULL,name,len))) goto have_candidate; } continue; } else candidate = *gvp; - have_candidate: + + have_candidate: assert(candidate); - if (SvTYPE(candidate) != SVt_PVGV) - gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8); + if (SvTYPE(candidate) != SVt_PVGV) gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { - /* - * Found real method, cache method in topgv if: - * 1. topgv has no synonyms (else inheritance crosses wires) - * 2. method isn't a stub (else AUTOLOAD fails spectacularly) - */ - if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - CV *old_cv = GvCV(topgv); + /* Found real method, cache method in cachegv if method isn't a stub (else AUTOLOAD fails spectacularly) */ + if (cachegv && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + CV *old_cv = GvCV(cachegv); SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV_set(topgv, cand_cv); - GvCVGEN(topgv) = topgen_cmp; + GvCV_set(cachegv, cand_cv); + GvCVGEN(cachegv) = meta->cache_gen + meta->pkg_gen + PL_sub_generation; /* cant use "cachegen", it could be changed */ } - return candidate; + return candidate; } } - /* Check UNIVERSAL without caching */ - if(level == 0 || level == -1) { - candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER); - if(candidate) { + if (level == 0 || level == -1) { + /* Check UNIVERSAL without caching */ + candidate = gv_fetchmeth_pvn(NULL, name, len, 0, flags &~GV_SUPER); + if (candidate) { cand_cv = GvCV(candidate); - if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - CV *old_cv = GvCV(topgv); + if (cachegv && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + CV *old_cv = GvCV(cachegv); SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV_set(topgv, cand_cv); - GvCVGEN(topgv) = topgen_cmp; + GvCV_set(cachegv, cand_cv); + GvCVGEN(cachegv) = meta->cache_gen + meta->pkg_gen + PL_sub_generation; } return candidate; } } - if (topgv && GvREFCNT(topgv) == 1) { - /* cache the fact that the method is not defined */ - GvCVGEN(topgv) = topgen_cmp; - } + if (cachegv) GvCVGEN(cachegv) = cachegen; /* cache the fact that the method is not defined */ return 0; } +GV* +Perl_gv_fetchmeth_pvn (pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { + SVMAP_ENT entry; + PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; + entry.name = name; + entry.len = len; + entry.flags = flags & SVf_UTF8; + entry.hash = PERL_HASH64(name, len); + return gv_fetchmeth_ent(stash, &entry, level, flags); +} + /* =for apidoc gv_fetchmeth_autoload @@ -861,26 +896,21 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; if (!gv) { - CV *cv; - GV **gvp; - - if (!stash) - return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) - return NULL; - cv = GvCV(gv); - if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; - /* Have an autoload */ - if (level < 0) /* Cannot do without a stub */ - gv_fetchmeth_pvn(stash, name, len, 0, flags); - gvp = (GV**)hv_fetch(stash, name, - (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); - if (!gvp) - return NULL; - return *gvp; + CV *cv; + + if (!stash) + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) + return NULL; + cv = GvCV(gv); + if (!(CvROOT(cv) || CvXSUB(cv))) + return NULL; + /* Have an autoload - need to create a glob for autoload in stash's HV */ + gv = *((GV**)hv_fetch(stash, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, 1)); + if (SvTYPE(gv) != SVt_PVGV) gv_init_pvn(gv, stash, name, len, GV_ADDMULTI|(flags & SVf_UTF8)); + return gv; } return gv; } @@ -940,138 +970,153 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags); } -/* Don't merge this yet, as it's likely to get a len parameter, and possibly - even a U32 hash */ -GV * -Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) -{ - const char *nend; - const char *nsplit = NULL; +GV* +Perl_gv_fetchmethod_ent (pTHX_ HV *stash, const SVMAP_ENT* entry, U32 flags) { GV* gv; - HV* ostash = stash; - const char * const origname = name; - SV *const error_report = MUTABLE_SV(stash); - const U32 autoload = flags & GV_AUTOLOAD; - const U32 do_croak = flags & GV_CROAK; - const U32 is_utf8 = flags & SVf_UTF8; + U32 is_utf8; + const char* name; + STRLEN len; + HV* origstash = stash; - PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; + PERL_ARGS_ASSERT_GV_FETCHMETHOD_ENT; - if (SvTYPE(stash) < SVt_PVHV) - stash = NULL; - else { - /* The only way stash can become NULL later on is if nsplit is set, - which in turn means that there is no need for a SVt_PVHV case - the error reporting code. */ - } + if (SvTYPE(stash) >= SVt_PVHV) { + SVMAP_ENT* cache_found; + struct mro_meta* meta; + SVMAP* method_cache; - for (nend = name; *nend || nend != (origname + len); nend++) { - if (*nend == '\'') { - nsplit = nend; - name = nend + 1; - } - else if (*nend == ':' && *(nend + 1) == ':') { - nsplit = nend++; - name = nend + 1; - } - } - if (nsplit) { - if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { - /* ->SUPER::method should really be looked up in original stash */ - stash = CopSTASH(PL_curcop); - flags |= GV_SUPER; - DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvENAME_get(stash), name) ); - } - else if ((nsplit - origname) >= 7 && - strnEQ(nsplit - 7, "::SUPER", 7)) { - /* don't autovifify if ->NoSuchStash::SUPER::method */ - stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8); - if (stash) flags |= GV_SUPER; - } - else { - /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, is_utf8); - } - ostash = stash; + meta = HvMROMETA(stash); + + if (UNLIKELY(flags & GV_SUPER)) method_cache = meta->mro_supermethod; + else method_cache = meta->mro_method; + + if (method_cache && (cache_found = svmap_find(method_cache, entry))) { + gv = cache_found->value.gv; + if (GvCVGEN(gv) == meta->cache_gen + meta->pkg_gen + PL_sub_generation) { + if (GvCV(gv)) return gv; + else if (!(flags & GV_CROAK)) { + /* definitely has no method. speedup common case - no AUTOLOAD, no GV_CROAK flag (->can('nometh')) */ + if (!svmap_find(method_cache, &S_autoent)) return NULL; + } + } + } } + else stash = NULL; - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); - if (!gv) { - if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = MUTABLE_GV(&PL_sv_yes); - else if (autoload) - gv = gv_autoload_pvn( - ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags - ); - if (!gv && do_croak) { - /* Right now this is exclusively for the benefit of S_method_common - in pp_hot.c */ - if (stash) { - /* If we can't find an IO::File method, it might be a call on - * a filehandle. If IO:File has not been loaded, try to - * require it first instead of croaking */ - const char *stash_name = HvNAME_get(stash); - if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") - && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, - STR_WITH_LEN("IO/File.pm"), 0, - HV_FETCH_ISEXISTS, NULL, 0) - ) { - require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); - if (gv) - return gv; - } - Perl_croak(aTHX_ - "Can't locate object method \"%"UTF8f - "\" via package \"%"HEKf"\"", - UTF8fARG(is_utf8, nend - name, name), - HEKfARG(HvNAME_HEK(stash))); - } - else { - SV* packnamesv; + is_utf8 = entry->flags & SVf_UTF8; + flags |= is_utf8; + name = entry->name; + len = entry->len; - if (nsplit) { - packnamesv = newSVpvn_flags(origname, nsplit - origname, - SVs_TEMP | is_utf8); - } else { - packnamesv = error_report; - } + gv = gv_fetchmeth_ent(stash, entry, 0, flags); - Perl_croak(aTHX_ - "Can't locate object method \"%"UTF8f - "\" via package \"%"SVf"\"" - " (perhaps you forgot to load \"%"SVf"\"?)", - UTF8fARG(is_utf8, nend - name, name), - SVfARG(packnamesv), SVfARG(packnamesv)); - } - } + if (!gv) { + if (strEQ(name,"import") || strEQ(name,"unimport")) gv = MUTABLE_GV(&PL_sv_yes); + else if (flags & GV_AUTOLOAD) gv = gv_autoload_pvn(origstash, name, len, GV_AUTOLOAD_ISMETHOD|flags); + + if (!gv && (flags & GV_CROAK)) { + /* Right now this is exclusively for the benefit of pp_method* in pp_hot.c */ + if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char* stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, STR_WITH_LEN("IO/File.pm"), 0, HV_FETCH_ISEXISTS, NULL, 0)) + { + require_pv("IO/File.pm"); + gv = gv_fetchmeth_pvn(stash, name, len, 0, flags); + if (gv) return gv; + } + Perl_croak(aTHX_ + "Can't locate object method \"%"UTF8f"\" via package \"%"HEKf"\"", + UTF8fARG(is_utf8, len, name), HEKfARG(HvNAME_HEK(stash)) + ); + } + else { + Perl_croak(aTHX_ + "Can't locate object method \"%"UTF8f"\" via package \"%"SVf"\" (perhaps you forgot to load \"%"SVf"\"?)", + UTF8fARG(is_utf8, len, name), SVfARG(MUTABLE_SV(origstash)), SVfARG(MUTABLE_SV(origstash)) + ); + } + } } - else if (autoload) { - CV* const cv = GvCV(gv); - if (!CvROOT(cv) && !CvXSUB(cv)) { - GV* stubgv; - GV* autogv; + else if (flags & GV_AUTOLOAD) { + CV* const cv = GvCV(gv); + if (!CvROOT(cv) && !CvXSUB(cv)) { + GV* stubgv; + GV* autogv; - if (CvANON(cv) || !CvGV(cv)) - stubgv = gv; - else { - stubgv = CvGV(cv); - if (GvCV(stubgv) != cv) /* orphaned import */ - stubgv = gv; - } - autogv = gv_autoload_pvn(GvSTASH(stubgv), - GvNAME(stubgv), GvNAMELEN(stubgv), - GV_AUTOLOAD_ISMETHOD - | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); - if (autogv) - gv = autogv; - } + if (CvANON(cv) || !CvGV(cv)) stubgv = gv; + else { + stubgv = CvGV(cv); + if (GvCV(stubgv) != cv) stubgv = gv; /* orphaned import */ + } + + autogv = gv_autoload_pvn( + GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), GV_AUTOLOAD_ISMETHOD | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0) + ); + if (autogv) gv = autogv; + } } return gv; } +GV* +Perl_gv_fetchmethod_pvn_flags (pTHX_ HV* stash, const char* name, STRLEN len, U32 flags) { + SVMAP_ENT entry; + PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; + + if (!(flags & GV_METHOD_SIMPLE) && memchr(name, ':', len)) { + const char* nend; + const char* nsplit = NULL; + const char*const origname = name; + for (nend = name + len - 2; nend > name; nend -= 2) + if (UNLIKELY(*nend == ':')) { + if (*(nend-1) == ':') { + nsplit = nend - 1; + len -= nend - name + 1; + name = nend + 1; + } + else if (*(nend+1) == ':') { + nsplit = nend; + len -= nend - name + 2; + name = nend + 2; + } + break; + } + + if (nsplit) { + STRLEN split_len = nsplit - origname; + if (split_len == 5 && memEQ(origname, "SUPER", 5)) { + /* ->SUPER::method should really be looked up in original stash */ + stash = CopSTASH(PL_curcop); + flags |= GV_SUPER; + DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvENAME_get(stash), name) ); + } + else if (split_len >= 7 && strnEQ(nsplit - 7, "::SUPER", 7)) { + /* don't autovifify if ->NoSuchStash::SUPER::method */ + stash = gv_stashpvn(origname, nsplit - origname - 7, flags & SVf_UTF8); + if (stash) flags |= GV_SUPER; + else stash = MUTABLE_HV(newSVpvn_flags(origname, nsplit - origname, SVs_TEMP | (flags & SVf_UTF8))); + } + else { + /* don't autovifify if ->NoSuchStash::method */ + stash = gv_stashpvn(origname, nsplit - origname, flags & SVf_UTF8); + if (!stash) stash = MUTABLE_HV(newSVpvn_flags(origname, nsplit - origname, SVs_TEMP | (flags & SVf_UTF8))); + } + } + } + + PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; + entry.name = name; + entry.len = len; + entry.flags = flags & SVf_UTF8; + entry.hash = PERL_HASH64(name, len); + return gv_fetchmethod_ent(stash, &entry, flags); +} + GV* Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) { @@ -1118,11 +1163,10 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); } - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, - is_utf8 | (flags & GV_SUPER)))) + if (!(gv = gv_fetchmeth_ent(stash, &S_autoent, FALSE, flags & GV_SUPER))) { return NULL; + } cv = GvCV(gv); - if (!(CvROOT(cv) || CvXSUB(cv))) return NULL; @@ -1131,7 +1175,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) */ if ( !(flags & GV_AUTOLOAD_ISMETHOD) - && (GvCVGEN(gv) || GvSTASH(gv) != stash) + && GvSTASH(gv) != stash ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Use of inherited AUTOLOAD for non-method %"SVf @@ -1313,9 +1357,8 @@ The most important of which are probably GV_ADD and SVf_UTF8. =cut */ -HV* -Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) -{ +PERL_STATIC_INLINE HV* +S_stashpvn (pTHX_ const char *name, U32 namelen, I32 flags) { char smallbuf[128]; char *tmpbuf; HV *stash; @@ -1340,7 +1383,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); if (!HvNAME_get(stash)) { - hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); + hv_name_set(stash, name, namelen, flags & SVf_UTF8); /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ /* If the containing stash has multiple effective @@ -1351,6 +1394,97 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) return stash; } +HV* +Perl_gv_stashent (pTHX_ const SVMAP_ENT* entry, I32 flags) { + SVMAP_ENT* found; + HV* stash; + PERL_ARGS_ASSERT_GV_STASHENT; + + if ((found = svmap_find(PL_stashcache, entry))) stash = found->value.hv; + else if (flags & GV_CACHE_ONLY) stash = NULL; + else { + stash = S_stashpvn(aTHX_ entry->name, entry->len, flags | entry->flags); + if (stash) { + U32 shash; + svmap_put_result res; + HEK* shek = share_hek(entry->name, (entry->flags & SVf_UTF8) ? -entry->len : entry->len, + PERL_HASH(shash, entry->name, entry->len)); + SVMAP_ENT putent = { + {NULL}, PERL_HASH64(HEK_KEY(shek), HEK_LEN(shek)), HEK_KEY(shek), HEK_LEN(shek), + HEK_UTF8(shek) ? SVf_UTF8 : 0 + }; + putent.value.hv = stash; + res = svmap_put(PL_stashcache, &putent, HMDR_FIND); + if (res.status != HMPR_PUT) unshare_hek(shek); /* S_stashpvn could result to gv_stashent call */ + } + } + + return stash; +} + +HV* +Perl_gv_stashpvn (pTHX_ const char* name, STRLEN namelen, I32 flags) { + SVMAP_ENT entry; + entry.hash = PERL_HASH64(name, namelen); + entry.flags = flags & SVf_UTF8; + entry.name = name; + entry.len = namelen; + return gv_stashent(&entry, flags); +} + +void +Perl_gv_stash_cache_init (pTHX) { + Newx(PL_stashcache, 1, SVMAP); + svmap_new(PL_stashcache); + svmap_reserve(PL_stashcache, 128); +} + +void +Perl_gv_stashpvn_cache_invalidate (pTHX_ const char *name, STRLEN namelen, I32 flags) { + SVMAP_ENT entry, *found; + const char* pvx; + PERL_ARGS_ASSERT_GV_STASHPVN_CACHE_INVALIDATE; + entry.hash = PERL_HASH64(name, namelen); + entry.flags = flags & SVf_UTF8; + entry.name = name; + entry.len = namelen; + if (!(found = svmap_find(PL_stashcache, &entry))) return; + pvx = found->name; + svmap_remove(PL_stashcache, found); + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); +} + +void +Perl_gv_stashsv_cache_invalidate (pTHX_ SV* sv) { + STRLEN len; + const char * const ptr = SvPV_const(sv,len); + PERL_ARGS_ASSERT_GV_STASHSV_CACHE_INVALIDATE; + gv_stashpvn_cache_invalidate(ptr, len, SvUTF8(sv)); +} + +PERL_STATIC_INLINE void +S_gv_stash_cache_erase (pTHX) { + SVMAP_ENT* iter; + HASHMAP_FOR_EACH(svmap, iter, *PL_stashcache) { + unshare_hek(SvSHARED_HEK_FROM_PV(iter->name)); + } HASHMAP_FOR_EACH_END +} + +void +Perl_gv_stash_cache_invalidate (pTHX) { + S_gv_stash_cache_erase(aTHX); + svmap_destroy(PL_stashcache); + svmap_reserve(PL_stashcache, 128); +} + +void +Perl_gv_stash_cache_destroy (pTHX) { + S_gv_stash_cache_erase(aTHX); + svmap_destroy(PL_stashcache); + Safefree(PL_stashcache); + PL_stashcache = NULL; +} + /* =for apidoc gv_stashsv @@ -2074,6 +2208,44 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) } } +HV * +Perl_gv_stashof_pvn (pTHX_ const char* name, STRLEN origlen, I32 flags, const svtype sv_type, const char** name_ret, STRLEN* len_ret, GV** gv_ret) { + const U32 is_utf8 = flags & SVf_UTF8; + const I32 add = flags & ~GV_NOADD_MASK; + HV* stash = NULL; + GV* gv = NULL; + const char* name_end = name + origlen; + STRLEN len; + + PERL_ARGS_ASSERT_GV_STASHOF_PVN; + + /* If we have GV_NOTQUAL, the caller promised that + * there is no stash, so we can skip the check. + * Similarly if full_len is 0, since then we're + * dealing with something like *{""} or ""->foo() + */ + if ((flags & GV_NOTQUAL) || !origlen) { + len = origlen; + } + else if (parse_gv_stash_name(&stash, &gv, &name, &len, name, origlen, is_utf8, add)) { + if (name == name_end || stash) goto ret; + } + else { + return NULL; + } + + if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { + return NULL; + } + + ret: + if (name_ret) *name_ret = name; + if (len_ret) *len_ret = len; + if (gv_ret) *gv_ret = gv; + return stash; +} + + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -2093,27 +2265,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; - /* If we have GV_NOTQUAL, the caller promised that - * there is no stash, so we can skip the check. - * Similarly if full_len is 0, since then we're - * dealing with something like *{""} or ""->foo() - */ - if ((flags & GV_NOTQUAL) || !full_len) { - len = full_len; - } - else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { - if (name == name_end) return gv; - } - else { - return NULL; - } + stash = gv_stashof_pvn(nambeg, full_len, flags, sv_type, &name, &len, &gv); + if (!stash) return NULL; + if (name == name_end && full_len) return gv; /* we're done for 'MyClass::' */ - if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { - return NULL; - } - /* By this point we should have a stash and a name */ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); + if (!gvp || *gvp == (const GV *)&PL_sv_undef) { if (addmg) gv = (GV *)newSV(0); else return NULL; @@ -2391,8 +2549,8 @@ Perl_gp_free(pTHX_ GV *gv) const HEK *hvname_hek = HvNAME_HEK(hv); DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek))); if (PL_stashcache && hvname_hek) - (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); - SvREFCNT_dec(hv); + gv_stashpvn_cache_invalidate(HEK_KEY(hvname_hek), HEK_LEN(hvname_hek), HEK_UTF8(hvname_hek) ? SVf_UTF8 : 0); + SvREFCNT_dec(hv); } SvREFCNT_dec(io); SvREFCNT_dec(cv); diff --git a/gv.h b/gv.h index d7ca92fb58c2..fdc621ad86f2 100644 --- a/gv.h +++ b/gv.h @@ -20,6 +20,7 @@ struct gp { GV * gp_egv; /* effective gv, if *glob */ line_t gp_line; /* line first declared at (for -w) */ HEK * gp_file_hek; /* file first declared in (for -w) */ + U32 gp_flags; /* flags for gp */ }; #define GvXPVGV(gv) ((XPVGV*)SvANY(gv)) @@ -199,6 +200,13 @@ Return the CV from the GV. #define GvIN_PAD_on(gv) (GvFLAGS(gv) |= GVf_IN_PAD) #define GvIN_PAD_off(gv) (GvFLAGS(gv) &= ~GVf_IN_PAD) +#define GPf_LOCALIZED 0x01 +#define GvGPFLAGS(gv) (GvGP(gv)->gp_flags) + +#define GvLOCALIZED(gv) (GvGPFLAGS(gv) & GPf_LOCALIZED) +#define GvLOCALIZED_on(gv) (GvGPFLAGS(gv) |= GPf_LOCALIZED) +#define GvLOCALIZED_off(gv) (GvGPFLAGS(gv) &= ~GPf_LOCALIZED) + #ifndef PERL_CORE # define Nullgv Null(GV*) #endif @@ -237,7 +245,11 @@ Return the CV from the GV. used only by gv_fetchsv(_nomg) */ /* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/ -#define GV_SUPER 0x1000 /* SUPER::method */ +#define GV_SUPER 0x1000 /* SUPER::method */ +#define GV_METHOD_SIMPLE 0x2000 /* gv_fetchmethod_flags() should not search for '::' in method name */ + +/* Flags for gv_stash*/ +#define GV_CACHE_ONLY 0x4000 /* gv_stashpvn should only return stash from cache or NULL if no entry in cache */ /* Flags for gv_autoload_*/ #define GV_AUTOLOAD_ISMETHOD 1 /* autoloading a method? */ diff --git a/hashmap.h b/hashmap.h new file mode 100644 index 000000000000..9816e7aaf44b --- /dev/null +++ b/hashmap.h @@ -0,0 +1,285 @@ +#ifndef HASHMAP_H__ +#define HASHMAP_H__ + +#define _HASHMAP_MINCAP 8 +#define _HASHMAP_BUCKET_MINCAP 1 + +typedef enum { + HMDR_FAIL = 0, /* returns old entry in parameter entry, lets NAME##Put() */ + /* "fail", i.e. return HMPR_FAILED */ + HMDR_FIND, /* returns old entry in parameter entry */ + HMDR_REPLACE, /* puts new entry, replaces current entry if exists */ + HMDR_SWAP, /* puts new entry, swappes old entry with *entry otherwise */ +} HashMapDuplicateResolution; + +typedef enum { + HMPR_FAILED = 0, /* map could not grow */ + HMPR_FOUND, /* item already existed */ + HMPR_REPLACED, /* item was replace */ + HMPR_SWAPPED, /* item already existed and was swapped with *entry */ + HMPR_PUT, /* new item was added to map */ +} HashMapPutStatus; + +#define _HASHMAP_BUCKET_NEXTCAP(min) \ + if (!min) min = _HASHMAP_BUCKET_MINCAP; \ + else { \ + min--; \ + min |= min >> 1; \ + min |= min >> 2; \ + min |= min >> 4; \ + min |= min >> 8; \ + min |= min >> 16; \ + /* uncomment for 64bit ints */ \ + /* min |= min >> 32; */ \ + min++; \ + } + +#define _HASHMAP_NEXTCAP(min) \ + if (!min) min = _HASHMAP_MINCAP; \ + else _HASHMAP_BUCKET_NEXTCAP(min); + +#define _HASHMAP_BUCKET(map, hash) &map->buckets[(hash) & (U64TYPE)(map->capacity-1)] + +#define DEFINE_HASHMAP(NAME, HASH_T, VAL_T) \ + typedef struct { \ + U32 size; \ + U32 capacity; \ + VAL_T* entries; \ + } NAME##_bucket; \ + \ + typedef struct { \ + U32 size; \ + U32 capacity; \ + NAME##_bucket* buckets; \ + } HASH_T; \ + \ + typedef struct { \ + VAL_T* entry; \ + HashMapPutStatus status; \ + } NAME##_put_result; \ + \ + typedef VAL_T _##NAME##_vtype; \ + typedef HASH_T _##NAME##_htype; \ + \ + void NAME##_new (HASH_T* map); \ + void NAME##_destroy (HASH_T* map); \ + bool NAME##_reserve (HASH_T* map, U32 capacity); \ + VAL_T* NAME##_find (const HASH_T* map, const _##NAME##_vtype* entry); \ + NAME##_put_result NAME##_put (HASH_T* map, VAL_T* entry, HashMapDuplicateResolution dr); \ + bool NAME##_remove (HASH_T* map, VAL_T* entry); + +/** + * To iterate over all entries in order they are saved in the map. + * You must not insert or delete elements in this loop. + * You can use continue and break as in usual for-loops. + * + * You HAVE TO put braces: + * HASHMAP_FOR_EACH(NAME, iter, map) { + * do_something(); + * } HASHMAP_FOR_EACH_END + * It's meant as a feature ... + * + * \param NAME Defined name of map + * \param ITER _##NAME##_vtype* denoting the current element. + * \param MAP Map to iterate over. + */ +#define HASHMAP_FOR_EACH(NAME, ITER, MAP) \ + do { \ + U32 __i, __h, __broke; \ + if(!(MAP).buckets || !(MAP).size) break; \ + for(__i = 0, __broke = 0; !__broke && __i < (MAP).capacity; ++__i) { \ + if(!(MAP).buckets[__i].entries) continue; \ + for(__h = 0; !__broke && __h < (MAP).buckets[__i].size; ++__h) { \ + ITER = &(MAP).buckets[__i].entries[__h]; \ + __broke = 1; \ + do + +/** + * Closes a HASHMAP_FOR_EACH(...) + */ +#define HASHMAP_FOR_EACH_END \ + while( __broke = 0, __broke ); \ + } \ + } \ + } while(0); + +/** + * Like HASHMAP_FOR_EACH(ITER, MAP), but you are safe to delete elements during + * the loop. You deleted elements may or may not show up during the for-loop! + */ +#define HASHMAP_FOR_EACH_SAFE_TO_DELETE(NAME, ITER, MAP) \ + do { \ + U32 __i, __h, __broke; \ + if(!(MAP).buckets || !(MAP).size) break; \ + for(__i = 0, __broke = 0; !__broke && __i < (MAP).capacity; ++__i) { \ + if(!(MAP).buckets[__i].entries) continue; \ + const U32 __size = (MAP).buckets[__i].size; \ + _##NAME##_vtype __entries[__size]; \ + memcpy(__entries, &(MAP).buckets[__i].entries, sizeof(__entries)); \ + for(__h = 0; !__broke && __h < __size; ++__h) { \ + ITER = &(MAP).buckets[__i].entries[__h]; \ + __broke = true; \ + do + +/** + * Closes a HASHMAP_FOR_EACH_SAFE_TO_DELETE(...) + */ +#define HASHMAP_FOR_EACH_SAFE_TO_DELETE_END HASHMAP_FOR_EACH_END + +/** + * Declares the hash map functions. + * \param NAME Typedef'd name of the HashMap type. + * \param CMP int (*cmp)(_##NAME##_vtype *left, _##NAME##_vtype *right). + * Could easily be a macro. Must return 0 if and only if *left + * equals *right. + * \param GET_HASH inttype (*getHash)(_##NAME##_vtype *entry). Could easily be + * a macro. + * \param FREE free() to use + * \param REALLOC realloc() to use. Assumes accordance with C standard, i.e. + * realloc(NULL, size) behaves as malloc(size). + */ +#define DECLARE_HASHMAP(NAME, CMP, GET_HASH, FREE, REALLOC) \ + \ +void NAME##_new (_##NAME##_htype* map) { \ + map->size = 0; \ + map->capacity = 0; \ + map->buckets = NULL; \ +} \ + \ +void NAME##_destroy (_##NAME##_htype* map) { \ + size_t i; \ + if (map->buckets) { \ + const size_t capacity = map->capacity; \ + for (i = 0; i < capacity; ++i) { \ + if (map->buckets[i].entries) FREE(map->buckets[i].entries); \ + } \ + FREE(map->buckets); \ + } \ + map->size = 0; \ + map->capacity = 0; \ + map->buckets = NULL; \ +} \ + \ +/* Helper function that puts an entry into the map, with checking the size */\ +/* or minding duplicates. */\ +/* \param map Map to put entry into. */\ +/* \param entry Entry to insert in map. */\ +/* \return pointer to inserted element, or NULL if could not grow */\ +static _##NAME##_vtype* \ +_##NAME##_put_real (_##NAME##_htype* map, const _##NAME##_vtype* entry) { \ + _##NAME##_vtype* result; \ + NAME##_bucket* bucket; \ + bucket = _HASHMAP_BUCKET(map, GET_HASH(entry)); \ + if (bucket->capacity <= bucket->size) { \ + size_t new_capacity = bucket->size + 1; \ + _HASHMAP_BUCKET_NEXTCAP(new_capacity); \ + if (!new_capacity) return NULL; \ + bucket->capacity = new_capacity; \ + result = (_##NAME##_vtype*)(REALLOC(bucket->entries, \ + sizeof(_##NAME##_vtype[new_capacity]))); \ + if (!result) return NULL; \ + bucket->entries = result; \ + } \ + result = &bucket->entries[bucket->size++]; \ + *result = *entry; \ + return result; \ +} \ + \ +bool NAME##_reserve (_##NAME##_htype* map, U32 capacity) { \ + size_t old_capacity, i, h; \ + NAME##_bucket *old_buckets, *new_buckets; \ + capacity = (capacity+2)/3 * 4; /* load factor = 0.75 */ \ + if (map->capacity >= capacity) return true; \ + _HASHMAP_NEXTCAP(capacity); \ + if (!capacity) return false; \ + old_capacity = map->capacity; \ + old_buckets = map->buckets; \ + map->capacity = capacity; \ + new_buckets = (NAME##_bucket*) REALLOC( \ + NULL, sizeof(NAME##_bucket[capacity]) \ + ); \ + if (!new_buckets) return false; \ + memset(new_buckets, 0, sizeof(NAME##_bucket[capacity])); \ + map->buckets = new_buckets; \ + /* TODO: a failed _##NAME##_put_real(...) would corrupt the map! */ \ + if (map->size) { \ + for (i = 0; i < old_capacity; ++i) { \ + for (h = 0; h < old_buckets->size; ++h) { \ + _##NAME##_put_real(map, &old_buckets->entries[h]); \ + } \ + FREE(old_buckets->entries); \ + old_buckets++; \ + } \ + } \ + FREE(old_buckets - old_capacity); \ + return true; \ +} \ + \ +_##NAME##_vtype* \ +NAME##_find (const _##NAME##_htype* map, const _##NAME##_vtype* entry) { \ + NAME##_bucket* bucket; \ + size_t h; \ + if (!map->buckets) return NULL; \ + bucket = _HASHMAP_BUCKET(map, GET_HASH(entry)); \ + for (h = 0; h < bucket->size; ++h) \ + if (!(CMP((&bucket->entries[h]), entry))) return &bucket->entries[h]; \ + return NULL; \ +} \ + \ +NAME##_put_result NAME##_put (_##NAME##_htype* map, _##NAME##_vtype* entry, \ + HashMapDuplicateResolution dr) { \ + NAME##_put_result result; \ + _##NAME##_vtype tmp; \ + if ((result.entry = NAME##_find(map, entry))) { \ + switch (dr) { \ + case HMDR_FAIL: \ + result.status = HMPR_FAILED; \ + return result; \ + case HMDR_REPLACE: \ + *result.entry = *entry; \ + result.status = HMPR_REPLACED; \ + return result; \ + case HMDR_SWAP: \ + tmp = *result.entry; \ + *result.entry = *entry; \ + *entry = tmp; \ + result.status = HMPR_SWAPPED; \ + return result; \ + case HMDR_FIND: \ + default: \ + result.status = HMPR_FOUND; \ + return result; \ + } \ + } \ + if (!NAME##_reserve(map, map->size+1)) { \ + result.status = HMPR_FAILED; \ + return result; \ + } \ + result.entry = _##NAME##_put_real(map, entry); \ + if (!result.entry) { \ + result.status = HMPR_FAILED; \ + return result; \ + } \ + ++map->size; \ + result.status = HMPR_PUT; \ + return result; \ +} \ + \ +bool NAME##_remove (_##NAME##_htype* map, _##NAME##_vtype* entry) { \ + NAME##_bucket* bucket; \ + size_t nth; \ + if (!map->size) return false; \ + bucket = _HASHMAP_BUCKET(map, GET_HASH(entry)); \ + for (nth = 0; nth < bucket->size; ++nth) { \ + if (!(CMP(entry, (&bucket->entries[nth])))) { \ + if (nth < bucket->size - 1) \ + bucket->entries[nth] = bucket->entries[bucket->size-1]; \ + --bucket->size; \ + --map->size; \ + return true; \ + } \ + } \ + return false; \ +} + +#endif /* ifndef HASHMAP_H__ */ diff --git a/hv.c b/hv.c index 5bab2d76406e..1155e11b421d 100644 --- a/hv.c +++ b/hv.c @@ -1837,11 +1837,25 @@ See also L. =cut */ +PERL_STATIC_INLINE void +S_mro_methcache_destroy (pTHX_ SVMAP** map) { + SVMAP_ENT* iter; + if (!*map) return; + HASHMAP_FOR_EACH(svmap, iter, **map) { + SvREFCNT_dec_NN(iter->value.gv); + unshare_hek(SvSHARED_HEK_FROM_PV(iter->name)); + } HASHMAP_FOR_EACH_END + svmap_destroy(*map); + Safefree(*map); + *map = NULL; +} + void Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) { XPVHV* xhv; bool save; + const char* hvname; if (!hv) return; @@ -1859,13 +1873,10 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if they will be freed anyway. */ /* note that the code following prior to hfreeentries is duplicated * in sv_clear(), and changes here should be done there too */ - if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) { - if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%" - HEKf"'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); - } - hv_name_set(hv, NULL, 0, 0); + if (PL_phase != PERL_PHASE_DESTRUCT && (hvname = HvNAME(hv))) { + DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(HvNAME_HEK(hv)))); + gv_stashpvn_cache_invalidate(hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); + hv_name_set(hv, NULL, 0, 0); } if (save) { ENTER; @@ -1875,27 +1886,23 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if (SvOOK(hv)) { struct mro_meta *meta; const char *name; + const char* hvename; - if (HvENAME_get(hv)) { - if (PL_phase != PERL_PHASE_DESTRUCT) - mro_isa_changed_in(hv); - if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%" - HEKf"'\n", HEKfARG(HvENAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD); - } + if ((hvename = HvENAME_get(hv))) { + if (PL_phase != PERL_PHASE_DESTRUCT) mro_isa_changed_in(hv); + DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"HEKf"'\n", HEKfARG(HvENAME_HEK(hv)))); + gv_stashpvn_cache_invalidate(hvename, HvENAMELEN(hv), HvENAMEUTF8(hv) ? SVf_UTF8 : 0); } /* If this call originated from sv_clear, then we must check for * effective names that need freeing, as well as the usual name. */ name = HvNAME(hv); if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) { - if (name && PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%" - HEKf"'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); + if (name) { + DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"HEKf"'\n", HEKfARG(HvNAME_HEK(hv)))); + gv_stashpvn_cache_invalidate(name, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); } - hv_name_set(hv, NULL, 0, flags); + hv_name_set(hv, NULL, 0, flags); } if((meta = HvAUX(hv)->xhv_mro_meta)) { if (meta->mro_linear_all) { @@ -1906,10 +1913,11 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) else /* Only the current MRO is stored, so this owns the data. */ - SvREFCNT_dec(meta->mro_linear_current); + SvREFCNT_dec(meta->mro_linear_current); + S_mro_methcache_destroy(aTHX_ &meta->mro_method); + S_mro_methcache_destroy(aTHX_ &meta->mro_supermethod); SvREFCNT_dec(meta->mro_nextmethod); SvREFCNT_dec(meta->isa); - SvREFCNT_dec(meta->super); Safefree(meta); HvAUX(hv)->xhv_mro_meta = NULL; } diff --git a/hv.h b/hv.h index 95dde4681ed4..40f862396873 100644 --- a/hv.h +++ b/hv.h @@ -76,13 +76,15 @@ struct mro_meta { is NULL, this owns the SV reference, else it is just a pointer to a value stored in and owned by mro_linear_all. */ SV *mro_linear_current; - HV *mro_nextmethod; /* next::method caching */ - U32 cache_gen; /* Bumping this invalidates our method cache */ - U32 pkg_gen; /* Bumps when local methods/@ISA change */ + SVMAP *mro_method; /* fetchmeth_pvn method caching */ + SVMAP *mro_supermethod; /* fetchmeth_pvn + SUPER flag method caching */ + HV *mro_nextmethod; /* next::method caching */ + U32 cache_gen; /* Bumping this invalidates our method cache */ + U32 pkg_gen; /* Bumps when local methods/@ISA change */ const struct mro_alg *mro_which; /* which mro alg is in use? */ - HV *isa; /* Everything this class @ISA */ - HV *super; /* SUPER method cache */ - U32 destroy_gen; /* Generation number of DESTROY cache */ + HV *isa; /* Everything this class @ISA */ + U32 destroy_gen; /* Generation number of DESTROY cache */ + }; #define MRO_GET_PRIVATE_DATA(smeta, which) \ diff --git a/hv_func.h b/hv_func.h index 1923f3ec20b5..53f2c2c1fe6f 100644 --- a/hv_func.h +++ b/hv_func.h @@ -559,6 +559,52 @@ S_perl_hash_old_one_at_a_time(const unsigned char * const seed, const unsigned c #define PERL_HASH_INTERNAL(hash,str,len) PERL_HASH(hash,str,len) #endif +#define PERL_HASH64(str,len) S_perl_hash64((const unsigned char*)(str),(len)) + +PERL_STATIC_INLINE U64TYPE +S_perl_hash64 (const unsigned char* str, const STRLEN len) { + const U64TYPE seed = 7; + const U64TYPE m = 0xc6a4a7935bd1e995LLU; + const int r = 47; + const U64TYPE* data; + const U64TYPE* end; + U64TYPE h; + + data = (const U64TYPE*) str; + end = data + (len/8); + + h = seed ^ (len * m); + + while (data != end) { + U64TYPE k; + k = *data++; + k *= m; + k ^= k >> r; + k *= m; + + h ^= k; + h *= m; + } + + str = (const unsigned char*) data; + switch (len & 7) { + case 7: h ^= ((U64TYPE)str[6]) << 48; + case 6: h ^= ((U64TYPE)str[5]) << 40; + case 5: h ^= ((U64TYPE)str[4]) << 32; + case 4: h ^= ((U64TYPE)str[3]) << 24; + case 3: h ^= ((U64TYPE)str[2]) << 16; + case 2: h ^= ((U64TYPE)str[1]) << 8; + case 1: h ^= ((U64TYPE)str[0]); + h *= m; + }; + + h ^= h >> r; + h *= m; + h ^= h >> r; + + return h; +} + #endif /*compile once*/ /* diff --git a/intrpvar.h b/intrpvar.h index 9dd4e167561d..20e864df7acf 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -147,7 +147,9 @@ PERLVAR(I, Sv, SV *) /* used to hold temporary values */ PERLVAR(I, parser, yy_parser *) /* current parser state */ -PERLVAR(I, stashcache, HV *) /* Cache to speed up S_method_common */ +PERLVAR(I, stashcache, SVMAP*) /* Cache to speed up stash lookups */ +PERLVARI(I, methstash, HV*, NULL); /* Holds the stash of the first argument (object/classname) if CV called as class/object method. + * NULL if CV called as function or via goto. Valid only until next CV call */ /* diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 470c8295f782..4f624fa2d518 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = '1.27'; +$VERSION = '1.28'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -34,7 +34,7 @@ BEGIN { OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST - PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) { + PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES OPpMETHOD_SUPER)) { eval { import B $_ }; no strict 'refs'; *{$_} = sub () {0} unless *{$_}{CODE}; @@ -556,7 +556,7 @@ sub begin_is_use { return unless $self->const_sv($svop)->PV eq $module; # Pull out the arguments - for ($svop=$svop->sibling; $svop->name ne "method_named"; + for ($svop=$svop->sibling; $svop->name !~ /^method_/; $svop = $svop->sibling) { $args .= ", " if length($args); $args .= $self->deparse($svop, 6); @@ -3653,8 +3653,14 @@ sub _method { $meth = $kid; } - if ($meth->name eq "method_named") { - $meth = $self->const_sv($meth)->PV; + if ($meth->name eq "method_named") { # $self->method + $meth = $self->const_meth($meth)->PV; + } elsif ($meth->name eq "method_super") { # $self->SUPER::method + $meth = "SUPER::".$self->const_meth($meth)->PV; + } elsif ($meth->name eq "method_redir") { + # one of : $self->Other::Class::method, $self->Other::SUPER::method + my $super = ($meth->private & OPpMETHOD_SUPER) ? 'SUPER::' : ''; + $meth = $self->const_rclass($meth)->PV."::$super".$self->const_meth($meth)->PV; } else { $meth = $meth->first; if ($meth->name eq "const") { @@ -4260,6 +4266,26 @@ sub const_sv { return $sv; } +sub const_meth { shift->const_sv(@_) } + +sub const_rclass { + my $self = shift; + my $op = shift; + my $sv = $op->rclass_sv or return undef; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->rclass_targ) unless $$sv; + return $sv; +} + +sub const_class { + my $self = shift; + my $op = shift; + my $sv = $op->class_sv or return undef; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->class_targ) unless $$sv; + return $sv; +} + sub pp_const { my $self = shift; my($op, $cx) = @_; diff --git a/lib/overload.t b/lib/overload.t index d89ec2a510f1..81e07db3c4b4 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 5194; +plan tests => 5193; use Scalar::Util qw(tainted); @@ -2364,14 +2364,11 @@ is eval {"$a"}, overload::StrVal($a), { package mane; use overload q\""\ => "bear::strength"; - use overload bool => "bear'bouillon"; } @bear::ISA = 'food'; sub food::strength { 'twine' } -sub food::bouillon { 0 } $a = bless[], mane::; is eval { "$a" }, 'twine', ':: in method name' or diag $@; -is eval { !$a }, 1, "' in method name" or diag $@; # [perl #113050] Half of CPAN assumes fallback is under "()" { diff --git a/mro.c b/mro.c index c9b40e5ec6dc..70c4d13c3ee8 100644 --- a/mro.c +++ b/mro.c @@ -186,7 +186,8 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) newmeta->isa = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); - newmeta->super = NULL; + newmeta->mro_method = NULL; + newmeta->mro_supermethod = NULL; return newmeta; } @@ -510,7 +511,6 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(!stashname) Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); - /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); CLEAR_LINEAR(meta); @@ -958,13 +958,11 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, const U32 name_utf8 = SvUTF8(*svp); STRLEN len; const char *name = SvPVx_const(*svp, len); - if(PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n", - SVfARG(*svp))); - (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); - } - ++svp; - hv_ename_delete(oldstash, name, len, name_utf8); + DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",SVfARG(*svp))); + gv_stashpvn_cache_invalidate(name, len, name_utf8); + + ++svp; + hv_ename_delete(oldstash, name, len, name_utf8); if (!fetched_isarev) { /* If the name deletion caused a name change, then we @@ -1312,9 +1310,55 @@ via, C. =cut */ + +PERL_STATIC_INLINE void +S_mro_method_cache_clear (pTHX_ SVMAP** method_cache_ptr) { + SVMAP_ENT* iter; + SVMAP* method_cache = *method_cache_ptr; + *method_cache_ptr = NULL; /* we may fall back to perl code and gv_fetchmeth during destruction on GV. Must remove cache map first */ + if (!method_cache) return; + HASHMAP_FOR_EACH(svmap, iter, *method_cache) { + SvREFCNT_dec_NN(iter->value.gv); + unshare_hek(SvSHARED_HEK_FROM_PV(iter->name)); + } HASHMAP_FOR_EACH_END + svmap_destroy(method_cache); + Safefree(method_cache); +} + +PERL_STATIC_INLINE void +S_mro_method_cache_clear_recursive (pTHX_ HV* stash) { + HV* substash; + SV* value; + char *key, *name, *subname; + I32 keylen, nelem; + STRLEN namelen; + struct mro_meta* meta = HvMROMETA(stash); + + if (meta->mro_method) S_mro_method_cache_clear(aTHX_ &meta->mro_method); + if (meta->mro_supermethod) S_mro_method_cache_clear(aTHX_ &meta->mro_supermethod); + + name = HvENAME_get(stash); + namelen = HvENAMELEN(stash); + nelem = hv_iterinit(stash); + while (nelem--) { + value = hv_iternextsv(stash, &key, &keylen); + if (keylen <= 2 || key[keylen-1] != ':' || key[keylen-2] != ':' || !isGV_with_GP(value) || !(substash = GvHV(value))) continue; + if (!(subname = HvENAME_get(substash)) || substash == stash) continue; + if (stash != PL_defstash && !memEQ(subname, name, namelen)) continue; /* avoid infinite recursion when Acme::META::{Acme::} == Acme:: */ + S_mro_method_cache_clear_recursive(aTHX_ substash); + } +} + +void +Perl_mro_global_method_cache_clear (pTHX) { + PL_sub_generation++; + S_mro_method_cache_clear_recursive(aTHX_ PL_defstash); +} + void Perl_mro_method_changed_in(pTHX_ HV *stash) { + struct mro_meta* meta; const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); @@ -1326,8 +1370,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); + meta = HvMROMETA(stash); /* Inc the package generation, since a local method changed */ - HvMROMETA(stash)->pkg_gen++; + meta->pkg_gen++; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; diff --git a/op.c b/op.c index e9de3a24e197..fae2525b975d 100644 --- a/op.c +++ b/op.c @@ -849,7 +849,38 @@ Perl_op_clear(pTHX_ OP *o) } } break; + case OP_METHOD_REDIR: + SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); + cMETHOPx(o)->op_rclass_sv = NULL; + cMETHOPx(o)->op_rclass_hash = 0; +#ifdef USE_ITHREADS + if (cMETHOPx(o)->op_rclass_targ) { + pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); + cMETHOPx(o)->op_rclass_targ = 0; + } +#endif case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + SvREFCNT_dec(cMETHOPx(o)->op_u.op_sv); + cMETHOPx(o)->op_u.op_sv = NULL; + cMETHOPx(o)->op_hash = 0; +#ifdef USE_ITHREADS + if (o->op_targ) { + pad_swipe(o->op_targ,1); + o->op_targ = 0; + } +#endif + case OP_METHOD: + SvREFCNT_dec(cMETHOPx(o)->op_class_sv); + cMETHOPx(o)->op_class_sv = NULL; + cMETHOPx(o)->op_class_hash = 0; +#ifdef USE_ITHREADS + if (cMETHOPx(o)->op_class_targ) { + pad_swipe(cMETHOPx(o)->op_class_targ, 1); + cMETHOPx(o)->op_class_targ = 0; + } +#endif + break; case OP_CONST: case OP_HINTSEVAL: SvREFCNT_dec(cSVOPo->op_sv); @@ -1310,8 +1341,7 @@ Perl_op_linklist(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_LINKLIST; - if (o->op_next) - return o->op_next; + if (o->op_next) return o->op_next; /* establish postfix order */ first = cUNOPo->op_first; @@ -2059,18 +2089,34 @@ Perl_finalize_optree(pTHX_ OP* o) ENTER; SAVEVPTR(PL_curcop); - finalize_op(o); LEAVE; } +#ifdef USE_ITHREADS +/* Relocate sv to the pad for thread safety. + * Despite being a "constant", the SV is written to, + * for reference counts, sv_upgrade() etc. */ +PERL_STATIC_INLINE void +S_relocate_opsv (pTHX_ SV** svp, PADOFFSET* targp) { + PADOFFSET ix; + if (!*svp) return; + ix = pad_alloc(OP_CONST, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(ix)); + PAD_SETSV(ix, *svp); + /* XXX I don't know how this isn't readonly already. */ + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); + *svp = NULL; + *targp = ix; +} +#endif + STATIC void S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; - switch (o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: @@ -2117,22 +2163,22 @@ S_finalize_op(pTHX_ OP* o) /* FALLTHROUGH */ #ifdef USE_ITHREADS case OP_HINTSEVAL: - case OP_METHOD_NAMED: - /* Relocate sv to the pad for thread safety. - * Despite being a "constant", the SV is written to, - * for reference counts, sv_upgrade() etc. */ - if (cSVOPo->op_sv) { - const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); - SvREFCNT_dec(PAD_SVl(ix)); - PAD_SETSV(ix, cSVOPo->op_sv); - /* XXX I don't know how this isn't readonly already. */ - if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); - cSVOPo->op_sv = NULL; - o->op_targ = ix; - } + S_relocate_opsv(aTHX_ &cSVOPo->op_sv, &o->op_targ); #endif break; +#ifdef USE_ITHREADS + /* Relocate all the METHOP's SVs to the pad for thread safety. */ + case OP_METHOD_REDIR: + S_relocate_opsv(aTHX_ &cMETHOPx(o)->op_rclass_sv, &cMETHOPx(o)->op_rclass_targ); + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + S_relocate_opsv(aTHX_ &cMETHOPx(o)->op_u.op_sv, &o->op_targ); + case OP_METHOD: + S_relocate_opsv(aTHX_ &cMETHOPx(o)->op_class_sv, &cMETHOPx(o)->op_class_targ); + break; +#endif + case OP_HELEM: { UNOP *rop; SV *lexname; @@ -2907,7 +2953,7 @@ STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { OP *pack, *imop, *arg; - SV *meth, *stashsv, **svp; + SV *stashsv, **svp; PERL_ARGS_ASSERT_APPLY_ATTRS_MY; @@ -2943,11 +2989,10 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) dup_attrlist(attrs))); /* Fake up a method call to import */ - meth = newSVpvs_share("import"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOPnamed(OP_METHOD_NAMED, 0, newSVpvs_share("import")))); /* Combine the ops. */ *imopsp = op_append_elem(OP_LIST, *imopsp, imop); @@ -4295,6 +4340,51 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) return fold_constants(op_integerize(op_std_init((OP *) unop))); } +static OP* +S_newMETHOP(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) { + dVAR; + METHOP *methop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP); + + NewOp(1101, methop, 1, METHOP); + if (dynamic_meth) { + if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1); + methop->op_flags = (U8)(flags | OPf_KIDS); + methop->op_u.op_first = dynamic_meth; + methop->op_hash = 0; + methop->op_private = (U8)(1 | (flags >> 8)); + } + else { + assert(const_meth); + methop->op_flags = (U8)(flags & ~OPf_KIDS); + methop->op_u.op_sv = const_meth; + methop->op_hash = PERL_HASH64(SvPVX(const_meth), SvCUR(const_meth)); + methop->op_private = (U8)(0 | (flags >> 8)); + methop->op_next = (OP*)methop; + } + + methop->op_type = (OPCODE)type; + methop->op_ppaddr = PL_ppaddr[type]; + methop->op_class_hash = methop->op_rclass_hash = 0; + methop = (METHOP*) CHECKOP(type, methop); + + if (methop->op_next) return (OP*)methop; + + return fold_constants(op_integerize(op_std_init((OP *) methop))); +} + +OP * +Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { + return S_newMETHOP(aTHX_ type, flags, dynamic_meth, NULL); +} + +OP * +Perl_newMETHOPnamed (pTHX_ I32 type, I32 flags, SV* const_meth) { + PERL_ARGS_ASSERT_NEWMETHOPNAMED; + return S_newMETHOP(aTHX_ type, flags, NULL, const_meth); +} + /* =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last @@ -5337,7 +5427,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) } else { OP *pack; - SV *meth; if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be a constant number"); @@ -5346,11 +5435,10 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ - meth = newSVpvs_share("VERSION"); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(version)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOPnamed(OP_METHOD_NAMED, 0, newSVpvs_share("VERSION")))); } } @@ -5366,18 +5454,20 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) idop->op_private |= OPpCONST_NOVER; } else { - SV *meth; /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ - meth = aver - ? newSVpvs_share("import") : newSVpvs_share("unimport"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOPnamed(OP_METHOD_NAMED, 0, + aver ? newSVpvs_share("import") : + newSVpvs_share("unimport") + ) + ) + ); } /* Fake up the BEGIN {}, which does its thing immediately. */ @@ -7713,6 +7803,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ + HV* stash; if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, @@ -7725,6 +7816,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else sv_setiv(MUTABLE_SV(gv), -1); + stash = gv_stashof_pvn(name, namlen, name_is_utf8 ? (gv_fetch_flags|SVf_UTF8) : gv_fetch_flags, SVt_PVCV, NULL, NULL, NULL); + if (stash) mro_method_changed_in(stash); + SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; @@ -7760,6 +7854,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } } } + if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; @@ -7784,6 +7879,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, PL_compcv = NULL; goto done; } + if (cv) { /* must reuse cv if autoloaded */ /* transfer PL_compcv to cv */ if (block @@ -9569,27 +9665,48 @@ Perl_ck_match(pTHX_ OP *o) OP * Perl_ck_method(pTHX_ OP *o) { - OP * const kid = cUNOPo->op_first; + SV *sv, *methsv; + const char* method; + int utf8; + STRLEN len, nsplit = 0, i; + OP* const kid = cMETHOPx(o)->op_u.op_first; PERL_ARGS_ASSERT_CK_METHOD; - if (kid->op_type == OP_CONST) { - SV* sv = kSVOP->op_sv; - const char * const method = SvPVX_const(sv); - if (!(strchr(method, ':') || strchr(method, '\''))) { - OP *cmop; - if (!SvIsCOW_shared_hash(sv)) { - sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); - } - else { - kSVOP->op_sv = NULL; - } - cmop = newSVOP(OP_METHOD_NAMED, 0, sv); - op_free(o); - return cmop; - } + if (kid->op_type != OP_CONST) return o; + + sv = cSVOPx(kid)->op_sv; + method = SvPV(sv, len); + utf8 = SvUTF8(sv) ? -1 : 1; + + for (i = len - 1; i > 0; --i) if (method[i] == ':') { + nsplit = i+1; + break; + } + + methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0); + + if (!nsplit) { /* $proto->method() */ + op_free(o); + return newMETHOPnamed(OP_METHOD_NAMED, 0, methsv); + } + + if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */ + op_free(o); + return newMETHOPnamed(OP_METHOD_SUPER, 0, methsv); + } + else if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) { /* $proto->MyClass::SUPER::method() */ + OP* op = newMETHOPnamed(OP_METHOD_REDIR, (OPpMETHOD_SUPER << 8), methsv); + cMETHOPx_set_rclass(op, newSVpvn_share(method, utf8*(nsplit-9), 0)); + op_free(o); + return op; + } + else { /* $proto->MyClass::method() redirect */ + OP* op = newMETHOPnamed(OP_METHOD_REDIR, 0, methsv); + cMETHOPx_set_rclass(op, newSVpvn_share(method, utf8*(nsplit-2), 0)); + op_free(o); + return op; } - return o; } OP * @@ -10647,6 +10764,7 @@ Perl_ck_subr(pTHX_ OP *o) OP *aop, *cvop; CV *cv; GV *namegv; + SV* sv = NULL; PERL_ARGS_ASSERT_CK_SUBR; @@ -10663,17 +10781,36 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; - if (cvop->op_type == OP_RV2CV) { - o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); - op_null(cvop); - } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { - if (aop->op_type == OP_CONST) - aop->op_private &= ~OPpCONST_STRICT; - else if (aop->op_type == OP_LIST) { - OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); - if (sib && sib->op_type == OP_CONST) - sib->op_private &= ~OPpCONST_STRICT; - } + switch(cvop->op_type) { + case OP_RV2CV: + o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + op_null(cvop); + break; + case OP_METHOD: + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: + o->op_private |= OPpENTERSUB_METHOD; + if (aop->op_type == OP_CONST) { + sv = cSVOPx(aop)->op_sv; + aop->op_private &= ~OPpCONST_STRICT; + } + else if (aop->op_type == OP_LIST) { + OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); + if (sib && sib->op_type == OP_CONST) { + sv = cSVOPx(sib)->op_sv; + sib->op_private &= ~OPpCONST_STRICT; + } + } + /* cache const class' name hash to speedup class method calls */ + if (sv) { + STRLEN len; + const char* str = SvPV(sv, len); + if (len) cMETHOPx_set_class(cvop, newSVpvn_share(str, SvUTF8(sv) ? -len : len, 0)); + } + break; + default: + break; } if (!cv) { diff --git a/op.h b/op.h index c76f37d74a0e..f00a6ebdca91 100644 --- a/op.h +++ b/op.h @@ -41,21 +41,21 @@ typedef PERL_BITFIELD16 Optype; #ifdef BASEOP_DEFINITION #define BASEOP BASEOP_DEFINITION #else -#define BASEOP \ - OP* op_next; \ - OP* op_sibling; \ - OP* (*op_ppaddr)(pTHX); \ - PADOFFSET op_targ; \ - PERL_BITFIELD16 op_type:9; \ - PERL_BITFIELD16 op_opt:1; \ - PERL_BITFIELD16 op_slabbed:1; \ - PERL_BITFIELD16 op_savefree:1; \ - PERL_BITFIELD16 op_static:1; \ - PERL_BITFIELD16 op_folded:1; \ - PERL_BITFIELD16 op_lastsib:1; \ - PERL_BITFIELD16 op_spare:1; \ - U8 op_flags; \ - U8 op_private; +#define BASEOP \ + OP* op_next; \ + OP* op_sibling; \ + OP* (*op_ppaddr)(pTHX); \ + PADOFFSET op_targ; \ + PERL_BITFIELD16 op_type:9; \ + PERL_BITFIELD16 op_opt:1; \ + PERL_BITFIELD16 op_slabbed:1; \ + PERL_BITFIELD16 op_savefree:1; \ + PERL_BITFIELD16 op_static:1; \ + PERL_BITFIELD16 op_folded:1; \ + PERL_BITFIELD16 op_lastsib:1; \ + PERL_BITFIELD16 op_spare:1; \ + U16 op_private; \ + U8 op_flags; #endif /* If op_type:9 is changed to :10, also change PUSHEVAL in cop.h. @@ -235,9 +235,13 @@ is no conversion of op type. in dynamic context */ #define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS) + /* OP_METHOD_* only */ +#define OPpMETHOD_SUPER 1 /* SUPER flag for OP_METHOD_REDIR */ + /* OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ #define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ +#define OPpENTERSUB_METHOD 256 /* object or class method call */ #define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */ /* OP_GV only */ @@ -385,6 +389,24 @@ struct listop { OP * op_last; }; +struct methop { + BASEOP + union { /* by nature METHOP is either extended UNOP (OP_METHOD) or extended SVOP (OP_METHOD_*) */ + OP* op_first; /* when UNOP: optree for method name */ + SV* op_sv; /* when SVOP: method name */ + } op_u; + /* method name for OP_METHOD_* ops lies in op_sv/op_targ, hash in op_hash */ + U64TYPE op_hash; + /* class name for OP_METHOD and OP_METHOD_* ops if it is const (MyClass->method) */ + SV* op_class_sv; + U64TYPE op_class_hash; /* zero if left operand is not a const ($class->method) */ + PADOFFSET op_class_targ; + /* alternate class name for OP_METHOD_REDIR op (if method is const) (MyClass->Other::method) */ + SV* op_rclass_sv; + U64TYPE op_rclass_hash; + PADOFFSET op_rclass_targ; +}; + struct pmop { BASEOP OP * op_first; @@ -543,6 +565,7 @@ struct loop { #define cPVOPx(o) ((PVOP*)o) #define cCOPx(o) ((COP*)o) #define cLOOPx(o) ((LOOP*)o) +#define cMETHOPx(o) ((METHOP*)o) #define cUNOP cUNOPx(PL_op) #define cBINOP cBINOPx(PL_op) @@ -588,14 +611,31 @@ struct loop { ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) # define cSVOPx_svp(v) (cSVOPx(v)->op_sv \ ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) +# define cMETHOPx_class_sv(v) (cMETHOPx(v)->op_class_sv ? cMETHOPx(v)->op_class_sv : PAD_SVl(cMETHOPx(v)->op_class_targ)) +# define cMETHOPx_rclass_sv(v) (cMETHOPx(v)->op_rclass_sv ? cMETHOPx(v)->op_rclass_sv : PAD_SVl(cMETHOPx(v)->op_rclass_targ)) #else # define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv) # define IS_PADGV(v) FALSE # define IS_PADCONST(v) FALSE # define cSVOPx_sv(v) (cSVOPx(v)->op_sv) # define cSVOPx_svp(v) (&cSVOPx(v)->op_sv) +# define cMETHOPx_class_sv(v) (cMETHOPx(v)->op_class_sv) +# define cMETHOPx_rclass_sv(v) (cMETHOPx(v)->op_rclass_sv) #endif +#define cMETHOPx_meth_sv(v) cSVOPx_sv(v) + +#define cMETHOPx_set_class(v,sv) do { \ + SV* _tmp = (sv); \ + cMETHOPx(v)->op_class_sv = _tmp; \ + cMETHOPx(v)->op_class_hash = PERL_HASH64(SvPVX(_tmp), SvCUR(_tmp)); \ + } while(0) +#define cMETHOPx_set_rclass(v,sv) do { \ + SV* _tmp = (sv); \ + cMETHOPx(v)->op_rclass_sv = _tmp; \ + cMETHOPx(v)->op_rclass_hash = PERL_HASH64(SvPVX(_tmp), SvCUR(_tmp)); \ + } while(0) + #define cGVOP_gv cGVOPx_gv(PL_op) #define cGVOPo_gv cGVOPx_gv(o) #define kGVOP_gv cGVOPx_gv(kid) diff --git a/opcode.h b/opcode.h index fbc3fe12ee85..0c546a11124a 100644 --- a/opcode.h +++ b/opcode.h @@ -350,6 +350,8 @@ EXTCONST char* const PL_op_name[] = { "goto", "exit", "method_named", + "method_super", + "method_redir", "entergiven", "leavegiven", "enterwhen", @@ -737,6 +739,8 @@ EXTCONST char* const PL_op_desc[] = { "goto", "exit", "method with known name", + "super method with known name", + "redirect method with known name", "given()", "leave given block", "when()", @@ -1138,6 +1142,8 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_goto, Perl_pp_exit, Perl_pp_method_named, + Perl_pp_method_super, + Perl_pp_method_redir, Perl_pp_entergiven, Perl_pp_leavegiven, Perl_pp_enterwhen, @@ -1535,6 +1541,8 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* goto */ Perl_ck_fun, /* exit */ Perl_ck_null, /* method_named */ + Perl_ck_null, /* method_super */ + Perl_ck_null, /* method_redir */ Perl_ck_null, /* entergiven */ Perl_ck_null, /* leavegiven */ Perl_ck_null, /* enterwhen */ @@ -1926,6 +1934,8 @@ EXTCONST U32 PL_opargs[] = { 0x00000d44, /* goto */ 0x00009b44, /* exit */ 0x00000640, /* method_named */ + 0x00000640, /* method_super */ + 0x00000640, /* method_redir */ 0x00000340, /* entergiven */ 0x00000100, /* leavegiven */ 0x00000340, /* enterwhen */ diff --git a/opnames.h b/opnames.h index 68ce927cd9e5..9616a1f936ff 100644 --- a/opnames.h +++ b/opnames.h @@ -216,187 +216,189 @@ typedef enum opcode { OP_GOTO = 199, OP_EXIT = 200, OP_METHOD_NAMED = 201, - OP_ENTERGIVEN = 202, - OP_LEAVEGIVEN = 203, - OP_ENTERWHEN = 204, - OP_LEAVEWHEN = 205, - OP_BREAK = 206, - OP_CONTINUE = 207, - OP_OPEN = 208, - OP_CLOSE = 209, - OP_PIPE_OP = 210, - OP_FILENO = 211, - OP_UMASK = 212, - OP_BINMODE = 213, - OP_TIE = 214, - OP_UNTIE = 215, - OP_TIED = 216, - OP_DBMOPEN = 217, - OP_DBMCLOSE = 218, - OP_SSELECT = 219, - OP_SELECT = 220, - OP_GETC = 221, - OP_READ = 222, - OP_ENTERWRITE = 223, - OP_LEAVEWRITE = 224, - OP_PRTF = 225, - OP_PRINT = 226, - OP_SAY = 227, - OP_SYSOPEN = 228, - OP_SYSSEEK = 229, - OP_SYSREAD = 230, - OP_SYSWRITE = 231, - OP_EOF = 232, - OP_TELL = 233, - OP_SEEK = 234, - OP_TRUNCATE = 235, - OP_FCNTL = 236, - OP_IOCTL = 237, - OP_FLOCK = 238, - OP_SEND = 239, - OP_RECV = 240, - OP_SOCKET = 241, - OP_SOCKPAIR = 242, - OP_BIND = 243, - OP_CONNECT = 244, - OP_LISTEN = 245, - OP_ACCEPT = 246, - OP_SHUTDOWN = 247, - OP_GSOCKOPT = 248, - OP_SSOCKOPT = 249, - OP_GETSOCKNAME = 250, - OP_GETPEERNAME = 251, - OP_LSTAT = 252, - OP_STAT = 253, - OP_FTRREAD = 254, - OP_FTRWRITE = 255, - OP_FTREXEC = 256, - OP_FTEREAD = 257, - OP_FTEWRITE = 258, - OP_FTEEXEC = 259, - OP_FTIS = 260, - OP_FTSIZE = 261, - OP_FTMTIME = 262, - OP_FTATIME = 263, - OP_FTCTIME = 264, - OP_FTROWNED = 265, - OP_FTEOWNED = 266, - OP_FTZERO = 267, - OP_FTSOCK = 268, - OP_FTCHR = 269, - OP_FTBLK = 270, - OP_FTFILE = 271, - OP_FTDIR = 272, - OP_FTPIPE = 273, - OP_FTSUID = 274, - OP_FTSGID = 275, - OP_FTSVTX = 276, - OP_FTLINK = 277, - OP_FTTTY = 278, - OP_FTTEXT = 279, - OP_FTBINARY = 280, - OP_CHDIR = 281, - OP_CHOWN = 282, - OP_CHROOT = 283, - OP_UNLINK = 284, - OP_CHMOD = 285, - OP_UTIME = 286, - OP_RENAME = 287, - OP_LINK = 288, - OP_SYMLINK = 289, - OP_READLINK = 290, - OP_MKDIR = 291, - OP_RMDIR = 292, - OP_OPEN_DIR = 293, - OP_READDIR = 294, - OP_TELLDIR = 295, - OP_SEEKDIR = 296, - OP_REWINDDIR = 297, - OP_CLOSEDIR = 298, - OP_FORK = 299, - OP_WAIT = 300, - OP_WAITPID = 301, - OP_SYSTEM = 302, - OP_EXEC = 303, - OP_KILL = 304, - OP_GETPPID = 305, - OP_GETPGRP = 306, - OP_SETPGRP = 307, - OP_GETPRIORITY = 308, - OP_SETPRIORITY = 309, - OP_TIME = 310, - OP_TMS = 311, - OP_LOCALTIME = 312, - OP_GMTIME = 313, - OP_ALARM = 314, - OP_SLEEP = 315, - OP_SHMGET = 316, - OP_SHMCTL = 317, - OP_SHMREAD = 318, - OP_SHMWRITE = 319, - OP_MSGGET = 320, - OP_MSGCTL = 321, - OP_MSGSND = 322, - OP_MSGRCV = 323, - OP_SEMOP = 324, - OP_SEMGET = 325, - OP_SEMCTL = 326, - OP_REQUIRE = 327, - OP_DOFILE = 328, - OP_HINTSEVAL = 329, - OP_ENTEREVAL = 330, - OP_LEAVEEVAL = 331, - OP_ENTERTRY = 332, - OP_LEAVETRY = 333, - OP_GHBYNAME = 334, - OP_GHBYADDR = 335, - OP_GHOSTENT = 336, - OP_GNBYNAME = 337, - OP_GNBYADDR = 338, - OP_GNETENT = 339, - OP_GPBYNAME = 340, - OP_GPBYNUMBER = 341, - OP_GPROTOENT = 342, - OP_GSBYNAME = 343, - OP_GSBYPORT = 344, - OP_GSERVENT = 345, - OP_SHOSTENT = 346, - OP_SNETENT = 347, - OP_SPROTOENT = 348, - OP_SSERVENT = 349, - OP_EHOSTENT = 350, - OP_ENETENT = 351, - OP_EPROTOENT = 352, - OP_ESERVENT = 353, - OP_GPWNAM = 354, - OP_GPWUID = 355, - OP_GPWENT = 356, - OP_SPWENT = 357, - OP_EPWENT = 358, - OP_GGRNAM = 359, - OP_GGRGID = 360, - OP_GGRENT = 361, - OP_SGRENT = 362, - OP_EGRENT = 363, - OP_GETLOGIN = 364, - OP_SYSCALL = 365, - OP_LOCK = 366, - OP_ONCE = 367, - OP_CUSTOM = 368, - OP_REACH = 369, - OP_RKEYS = 370, - OP_RVALUES = 371, - OP_COREARGS = 372, - OP_RUNCV = 373, - OP_FC = 374, - OP_PADCV = 375, - OP_INTROCV = 376, - OP_CLONECV = 377, - OP_PADRANGE = 378, + OP_METHOD_SUPER = 202, + OP_METHOD_REDIR = 203, + OP_ENTERGIVEN = 204, + OP_LEAVEGIVEN = 205, + OP_ENTERWHEN = 206, + OP_LEAVEWHEN = 207, + OP_BREAK = 208, + OP_CONTINUE = 209, + OP_OPEN = 210, + OP_CLOSE = 211, + OP_PIPE_OP = 212, + OP_FILENO = 213, + OP_UMASK = 214, + OP_BINMODE = 215, + OP_TIE = 216, + OP_UNTIE = 217, + OP_TIED = 218, + OP_DBMOPEN = 219, + OP_DBMCLOSE = 220, + OP_SSELECT = 221, + OP_SELECT = 222, + OP_GETC = 223, + OP_READ = 224, + OP_ENTERWRITE = 225, + OP_LEAVEWRITE = 226, + OP_PRTF = 227, + OP_PRINT = 228, + OP_SAY = 229, + OP_SYSOPEN = 230, + OP_SYSSEEK = 231, + OP_SYSREAD = 232, + OP_SYSWRITE = 233, + OP_EOF = 234, + OP_TELL = 235, + OP_SEEK = 236, + OP_TRUNCATE = 237, + OP_FCNTL = 238, + OP_IOCTL = 239, + OP_FLOCK = 240, + OP_SEND = 241, + OP_RECV = 242, + OP_SOCKET = 243, + OP_SOCKPAIR = 244, + OP_BIND = 245, + OP_CONNECT = 246, + OP_LISTEN = 247, + OP_ACCEPT = 248, + OP_SHUTDOWN = 249, + OP_GSOCKOPT = 250, + OP_SSOCKOPT = 251, + OP_GETSOCKNAME = 252, + OP_GETPEERNAME = 253, + OP_LSTAT = 254, + OP_STAT = 255, + OP_FTRREAD = 256, + OP_FTRWRITE = 257, + OP_FTREXEC = 258, + OP_FTEREAD = 259, + OP_FTEWRITE = 260, + OP_FTEEXEC = 261, + OP_FTIS = 262, + OP_FTSIZE = 263, + OP_FTMTIME = 264, + OP_FTATIME = 265, + OP_FTCTIME = 266, + OP_FTROWNED = 267, + OP_FTEOWNED = 268, + OP_FTZERO = 269, + OP_FTSOCK = 270, + OP_FTCHR = 271, + OP_FTBLK = 272, + OP_FTFILE = 273, + OP_FTDIR = 274, + OP_FTPIPE = 275, + OP_FTSUID = 276, + OP_FTSGID = 277, + OP_FTSVTX = 278, + OP_FTLINK = 279, + OP_FTTTY = 280, + OP_FTTEXT = 281, + OP_FTBINARY = 282, + OP_CHDIR = 283, + OP_CHOWN = 284, + OP_CHROOT = 285, + OP_UNLINK = 286, + OP_CHMOD = 287, + OP_UTIME = 288, + OP_RENAME = 289, + OP_LINK = 290, + OP_SYMLINK = 291, + OP_READLINK = 292, + OP_MKDIR = 293, + OP_RMDIR = 294, + OP_OPEN_DIR = 295, + OP_READDIR = 296, + OP_TELLDIR = 297, + OP_SEEKDIR = 298, + OP_REWINDDIR = 299, + OP_CLOSEDIR = 300, + OP_FORK = 301, + OP_WAIT = 302, + OP_WAITPID = 303, + OP_SYSTEM = 304, + OP_EXEC = 305, + OP_KILL = 306, + OP_GETPPID = 307, + OP_GETPGRP = 308, + OP_SETPGRP = 309, + OP_GETPRIORITY = 310, + OP_SETPRIORITY = 311, + OP_TIME = 312, + OP_TMS = 313, + OP_LOCALTIME = 314, + OP_GMTIME = 315, + OP_ALARM = 316, + OP_SLEEP = 317, + OP_SHMGET = 318, + OP_SHMCTL = 319, + OP_SHMREAD = 320, + OP_SHMWRITE = 321, + OP_MSGGET = 322, + OP_MSGCTL = 323, + OP_MSGSND = 324, + OP_MSGRCV = 325, + OP_SEMOP = 326, + OP_SEMGET = 327, + OP_SEMCTL = 328, + OP_REQUIRE = 329, + OP_DOFILE = 330, + OP_HINTSEVAL = 331, + OP_ENTEREVAL = 332, + OP_LEAVEEVAL = 333, + OP_ENTERTRY = 334, + OP_LEAVETRY = 335, + OP_GHBYNAME = 336, + OP_GHBYADDR = 337, + OP_GHOSTENT = 338, + OP_GNBYNAME = 339, + OP_GNBYADDR = 340, + OP_GNETENT = 341, + OP_GPBYNAME = 342, + OP_GPBYNUMBER = 343, + OP_GPROTOENT = 344, + OP_GSBYNAME = 345, + OP_GSBYPORT = 346, + OP_GSERVENT = 347, + OP_SHOSTENT = 348, + OP_SNETENT = 349, + OP_SPROTOENT = 350, + OP_SSERVENT = 351, + OP_EHOSTENT = 352, + OP_ENETENT = 353, + OP_EPROTOENT = 354, + OP_ESERVENT = 355, + OP_GPWNAM = 356, + OP_GPWUID = 357, + OP_GPWENT = 358, + OP_SPWENT = 359, + OP_EPWENT = 360, + OP_GGRNAM = 361, + OP_GGRGID = 362, + OP_GGRENT = 363, + OP_SGRENT = 364, + OP_EGRENT = 365, + OP_GETLOGIN = 366, + OP_SYSCALL = 367, + OP_LOCK = 368, + OP_ONCE = 369, + OP_CUSTOM = 370, + OP_REACH = 371, + OP_RKEYS = 372, + OP_RVALUES = 373, + OP_COREARGS = 374, + OP_RUNCV = 375, + OP_FC = 376, + OP_PADCV = 377, + OP_INTROCV = 378, + OP_CLONECV = 379, + OP_PADRANGE = 380, OP_max } opcode; -#define MAXO 379 +#define MAXO 381 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/perl.c b/perl.c index e84f1d53aec9..fd2877e34235 100644 --- a/perl.c +++ b/perl.c @@ -322,7 +322,7 @@ perl_construct(pTHXx) #endif PL_clocktick = HZ; - PL_stashcache = newHV(); + gv_stash_cache_init(); PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING); @@ -563,16 +563,19 @@ perl_destruct(pTHXx) } #endif + /* flush all method caches as some poorly written code depend on refcnt of scalars on END phase */ + mro_global_method_cache_clear(); + if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { dJMPENV; int x = 0; JMPENV_PUSH(x); - PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(x); if (PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); + PERL_SET_PHASE(PERL_PHASE_END); call_list(PL_scopestack_ix, PL_endav); - } + } JMPENV_POP; } LEAVE; @@ -873,10 +876,6 @@ perl_destruct(pTHXx) } #endif - - SvREFCNT_dec(MUTABLE_SV(PL_stashcache)); - PL_stashcache = NULL; - /* loosen bonds of global variables */ /* XXX can PL_parser still be non-null here? */ @@ -1133,6 +1132,9 @@ perl_destruct(pTHXx) PL_sv_consts[i] = NULL; } + PL_methstash = NULL; + gv_stash_cache_destroy(); + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -1325,6 +1327,7 @@ perl_destruct(pTHXx) Safefree(PL_mess_sv); PL_mess_sv = NULL; } + return STATUS_EXIT; } @@ -2643,8 +2646,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) { dVAR; dSP; LOGOP myop; /* fake syntax tree node */ - UNOP method_unop; - SVOP method_svop; + METHOP method_op; I32 oldmark; VOL I32 retval = 0; I32 oldscope; @@ -2673,8 +2675,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_op = (OP*)&myop; EXTEND(PL_stack_sp, 1); - if (!(flags & G_METHOD_NAMED)) - *++PL_stack_sp = sv; + *++PL_stack_sp = sv; oldmark = TOPMARK; oldscope = PL_scopestack_ix; @@ -2688,23 +2689,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) myop.op_private |= OPpENTERSUB_DB; if (flags & (G_METHOD|G_METHOD_NAMED)) { - if ( flags & G_METHOD_NAMED ) { - Zero(&method_svop, 1, SVOP); - method_svop.op_next = (OP*)&myop; - method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; - method_svop.op_type = OP_METHOD_NAMED; - method_svop.op_sv = sv; - PL_op = (OP*)&method_svop; - } else { - Zero(&method_unop, 1, UNOP); - method_unop.op_next = (OP*)&myop; - method_unop.op_ppaddr = PL_ppaddr[OP_METHOD]; - method_unop.op_type = OP_METHOD; - PL_op = (OP*)&method_unop; - } + Zero(&method_op, 1, METHOP); + method_op.op_next = (OP*)&myop; + method_op.op_type = OP_METHOD; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + PL_op = (OP*)&method_op; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; myop.op_type = OP_ENTERSUB; - } if (!(flags & G_EVAL)) { diff --git a/perl.h b/perl.h index 202e55e8b3af..01ec1fde2611 100644 --- a/perl.h +++ b/perl.h @@ -2307,6 +2307,7 @@ typedef MEM_SIZE STRLEN; typedef struct op OP; typedef struct cop COP; typedef struct unop UNOP; +typedef struct methop METHOP; typedef struct binop BINOP; typedef struct listop LISTOP; typedef struct logop LOGOP; @@ -2371,6 +2372,8 @@ typedef AV PAD; typedef AV PADNAMELIST; typedef SV PADNAME; +typedef struct svmap_entry SVMAP_ENT; + /* enable PERL_NEW_COPY_ON_WRITE by default */ #if !defined(PERL_OLD_COPY_ON_WRITE) && !defined(PERL_NEW_COPY_ON_WRITE) && !defined(PERL_NO_COW) # define PERL_NEW_COPY_ON_WRITE @@ -3349,6 +3352,8 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ # define PERL_BITFIELD32 unsigned #endif +#include "hashmap.h" + #include "sv.h" #include "regexp.h" #include "util.h" @@ -5920,6 +5925,8 @@ extern void moncontrol(int); #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII +#define PERLEXT_PANDA 1.0 + /* (KEEP THIS LAST IN perl.h!) diff --git a/perly.act b/perly.act index 61850f48e5ff..6bfe2b0a429c 100644 --- a/perly.act +++ b/perly.act @@ -718,7 +718,7 @@ case 2: { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)), - newUNOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval)))); + newMETHOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval)))); } break; @@ -726,7 +726,7 @@ case 2: #line 644 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)), - newUNOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval)))); + newMETHOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval)))); } break; @@ -735,7 +735,7 @@ case 2: { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)), - newUNOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval)))); + newMETHOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval)))); } break; @@ -744,7 +744,7 @@ case 2: { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)), - newUNOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval)))); + newMETHOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval)))); } break; @@ -1464,6 +1464,6 @@ case 2: /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 304625ecafb12d39df3c43a63a66f18501770731f29031dead3bb385d10a5baa perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.h b/perly.h index cd92798734db..bad5f2177624 100644 --- a/perly.h +++ b/perly.h @@ -276,6 +276,6 @@ int yyparse (); /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 304625ecafb12d39df3c43a63a66f18501770731f29031dead3bb385d10a5baa perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index bd3a25c75b1f..c50b589bfa27 100644 --- a/perly.tab +++ b/perly.tab @@ -1125,6 +1125,6 @@ static const toketypes yy_type_tab[] = }; /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 304625ecafb12d39df3c43a63a66f18501770731f29031dead3bb385d10a5baa perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index de90b2adcaa4..08fdd0e15a8b 100644 --- a/perly.y +++ b/perly.y @@ -638,24 +638,24 @@ listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, scalar($1), $5), - newUNOP(OP_METHOD, 0, $3))); + newMETHOP(OP_METHOD, 0, $3))); } | term ARROW method /* $foo->bar */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, scalar($1), - newUNOP(OP_METHOD, 0, $3))); + newMETHOP(OP_METHOD, 0, $3))); } | METHOD indirob optlistexpr /* new Class @args */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, $2, $3), - newUNOP(OP_METHOD, 0, $1))); + newMETHOP(OP_METHOD, 0, $1))); } | FUNCMETH indirob '(' optexpr ')' /* method $object (@args) */ { $$ = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, $2, $4), - newUNOP(OP_METHOD, 0, $1))); + newMETHOP(OP_METHOD, 0, $1))); } | LSTOP optlistexpr /* print @args */ { $$ = convert($1, 0, $2); } diff --git a/pp.h b/pp.h index a7e936ccaf49..85c1b9e269d6 100644 --- a/pp.h +++ b/pp.h @@ -89,6 +89,9 @@ Refetch the stack pointer. Used after a callback. See L. #define NORMAL PL_op->op_next #define DIE return Perl_die +#define dMETHSTASH HV* stash = (PL_methstash && SvTYPE(PL_methstash) == SVt_PVHV ? PL_methstash : curmethod_stash(&ST(0), cv)) +#define dMETHSTASH_NOCROAK HV* stash = (PL_methstash && SvTYPE(PL_methstash) == SVt_PVHV ? PL_methstash : curmethod_stash(&ST(0), NULL)) + /* =for apidoc Ams||PUTBACK Closing bracket for XSUB arguments. This is usually handled by C. diff --git a/pp_ctl.c b/pp_ctl.c index 7d098b739ddb..f162c946f8d5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2854,6 +2854,7 @@ PP(pp_goto) /* also pp_dump */ } /* Now do some callish stuff. */ + PL_methstash = NULL; /* goto is not a method call context */ SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { diff --git a/pp_hot.c b/pp_hot.c index 12a22cb3486d..c670c8263364 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2511,6 +2511,7 @@ PP(pp_leavesub) POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ cxstack_ix--; PL_curpm = newpm; /* ... and pop $1 et al */ + PL_methstash = NULL; /* reset PL_methstash cache on func/method end */ LEAVESUB(sv); return cx->blk_sub.retop; @@ -2647,6 +2648,8 @@ PP(pp_entersub) gimme = GIMME_V; + if (!(PL_op->op_private & OPpENTERSUB_METHOD)) PL_methstash = NULL; /* set NULL to PL_methstash if called as function */ + if (!(CvISXSUB(cv))) { /* This path taken at least 75% of the time */ dMARK; @@ -2931,155 +2934,198 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) return sv; } +#define _METHOD_STASH_NORMALIZE_METH(meth) \ + if (!meth) return NULL; \ + if (SvTYPE(meth) == SVt_PVCV) { \ + GV* subgv = CvGV(MUTABLE_CV(meth)); \ + if (subgv) meth = newSVpvn_flags(GvNAME(subgv), GvNAMELEN(subgv), SVs_TEMP | (GvNAMEUTF8(subgv) ? SVf_UTF8 : 0)); \ + else meth = newSVpvs_flags("__ANON__", SVs_TEMP); \ + } + +HV* +Perl_method_stash (pTHX_ SV** objptr, SV* meth) { + SV* const sv = *objptr; + HV* stash; + SV* ob; + PERL_ARGS_ASSERT_METHOD_STASH; + + if (UNLIKELY(!sv)) goto undefined; + + SvGETMAGIC(sv); + if (SvROK(sv)) ob = MUTABLE_SV(SvRV(sv)); + else if (!SvOK(sv)) goto undefined; + else if (isGV_with_GP(sv)) { + if (!GvIO(sv)) goto nopackobj; + ob = sv; + if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { + assert(!LvTARGLEN(ob)); + ob = LvTARG(ob); + assert(ob); + } + *objptr = sv_2mortal(newRV(ob)); + } + else { + /* this isn't a reference */ + STRLEN packlen; + GV* iogv; + const char * const packname = SvPV_nomg_const(sv, packlen); + const I32 stashpvn_flags = SvUTF8(sv); + if (!packlen) goto nopackobj; + + stash = gv_stashpvn(packname, packlen, stashpvn_flags | GV_CACHE_ONLY); + if (stash) { + DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n", (void*)stash, SVfARG(sv))); + return stash; + } + + if ( !(iogv = gv_fetchpvn_flags(packname, packlen, stashpvn_flags, SVt_PVIO)) || !(ob=MUTABLE_SV(GvIO(iogv))) ) { + /* this isn't the name of a filehandle either, assume it's a package name */ + stash = gv_stashpvn(packname, packlen, stashpvn_flags); + if (stash) { + DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n", (void*)stash, SVfARG(sv))); + return stash; + } + else return MUTABLE_HV(sv); + } + + /* it _is_ a filehandle name -- replace with a reference */ + *objptr = sv_2mortal(newRV(MUTABLE_SV(iogv))); + } + + /* if we got here, ob should be an object or a glob */ + if (!ob || !(SvOBJECT(ob) || (isGV_with_GP(ob) && (ob = MUTABLE_SV(GvIO((const GV *)ob))) && SvOBJECT(ob)))) + goto unblessed; + + return SvSTASH(ob); + + undefined: + _METHOD_STASH_NORMALIZE_METH(meth); + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", SVfARG(meth)); + nopackobj: + _METHOD_STASH_NORMALIZE_METH(meth); + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a package or object reference", SVfARG(meth)); + unblessed: + _METHOD_STASH_NORMALIZE_METH(meth); + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference", + SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa")) ? + newSVpvs_flags("DOES", SVs_TEMP) : meth)); +} + +PERL_STATIC_INLINE HV* +S_opmethod_stash (pTHX_ METHOP* op, SV* meth) { + PERL_ARGS_ASSERT_OPMETHOD_STASH; + if (op->op_class_hash) { + SV*const const_class = cMETHOPx_class_sv(op); + const SVMAP_ENT entry = SVMAP_ENT_SV(const_class, op->op_class_hash); + HV* stash = gv_stashent(&entry, GV_CACHE_ONLY); + if (stash) { + DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n", (void*)stash, SVfARG(const_class))); + return stash; + } + } + + if (UNLIKELY(PL_stack_base + TOPMARK == PL_stack_sp)) + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a package or object reference", SVfARG(meth)); + + return method_stash(PL_stack_base + TOPMARK + 1, meth); +} + + +HV* +Perl_curmethod_stash (pTHX_ SV** objptr, CV* sub) { + HV* stash; + PERL_ARGS_ASSERT_CURMETHOD_STASH; + stash = PL_methstash ? PL_methstash : method_stash(objptr, MUTABLE_SV(sub)); + /* PL_methstash and method_stash can return SV (package name when not yet exists) */ + if (!sub || SvTYPE(stash) == SVt_PVHV) return stash; + return gv_stashsv(MUTABLE_SV(stash), GV_ADD); +} + PP(pp_method) { dSP; - SV* const sv = TOPs; - - if (SvROK(sv)) { - SV* const rsv = SvRV(sv); - if (SvTYPE(rsv) == SVt_PVCV) { - SETs(rsv); - RETURN; - } + GV* gv; + STRLEN methlen; + const char* methpv; + SV* const meth = TOPs; + + if (SvROK(meth)) { + SV* const rsv = SvRV(meth); + if (SvTYPE(rsv) == SVt_PVCV) { + PL_methstash = NULL; /* $proto->$coderef() is not a method call context */ + SETs(rsv); + RETURN; + } } - SETs(method_common(sv, NULL)); + PL_methstash = opmethod_stash(cMETHOPx(PL_op), meth); + + methpv = SvPV(meth, methlen); + gv = gv_fetchmethod_pvn_flags(PL_methstash, methpv, methlen, GV_AUTOLOAD|GV_CROAK|SvUTF8(meth)); + assert(gv); + + SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); RETURN; } PP(pp_method_named) { dSP; - SV* const sv = cSVOP_sv; - U32 hash = SvSHARED_HASH(sv); + GV* gv; + SV* meth = cMETHOPx_meth_sv(PL_op); + const SVMAP_ENT meth_entry = SVMAP_ENT_SV(meth, cMETHOPx(PL_op)->op_hash); + + PL_methstash = opmethod_stash(cMETHOPx(PL_op), meth); - XPUSHs(method_common(sv, &hash)); + gv = gv_fetchmethod_ent(PL_methstash, &meth_entry, GV_AUTOLOAD|GV_CROAK); + assert(gv); + + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); RETURN; } -STATIC SV * -S_method_common(pTHX_ SV* meth, U32* hashp) +PP(pp_method_super) { - SV* ob; + dSP; GV* gv; - HV* stash; - SV *packsv = NULL; - SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp - ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a " - "package or object reference", SVfARG(meth)), - (SV *)NULL) - : *(PL_stack_base + TOPMARK + 1); - - PERL_ARGS_ASSERT_METHOD_COMMON; + SV* meth = cMETHOPx_meth_sv(PL_op); + const SVMAP_ENT meth_entry = SVMAP_ENT_SV(meth, cMETHOPx(PL_op)->op_hash); - if (UNLIKELY(!sv)) - undefined: - Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", - SVfARG(meth)); - - SvGETMAGIC(sv); - if (SvROK(sv)) - ob = MUTABLE_SV(SvRV(sv)); - else if (!SvOK(sv)) goto undefined; - else if (isGV_with_GP(sv)) { - if (!GvIO(sv)) - Perl_croak(aTHX_ "Can't call method \"%"SVf"\" " - "without a package or object reference", - SVfARG(meth)); - ob = sv; - if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { - assert(!LvTARGLEN(ob)); - ob = LvTARG(ob); - assert(ob); - } - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); - } - else { - /* this isn't a reference */ - GV* iogv; - STRLEN packlen; - const char * const packname = SvPV_nomg_const(sv, packlen); - const bool packname_is_utf8 = !!SvUTF8(sv); - const HE* const he = - (const HE *)hv_common( - PL_stashcache, NULL, packname, packlen, - packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0 - ); - - if (he) { - stash = INT2PTR(HV*,SvIV(HeVAL(he))); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n", - (void*)stash, SVfARG(sv))); - goto fetch; - } + /* Actually, SUPER doesn't need real object's (or class') stash at all, as it uses CopSTASH + * However, we must ensure that object(class) is correct (this check is done by S_method_stash), + * and additionaly set PL_methstash to a real stash for possible usage in user's code. + * op_const_class is probably NULL as code like "MyClass->SUPER::meth()" doesn't make sense */ + PL_methstash = opmethod_stash(cMETHOPx(PL_op), meth); - if (!(iogv = gv_fetchpvn_flags( - packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO - )) || - !(ob=MUTABLE_SV(GvIO(iogv)))) - { - /* this isn't the name of a filehandle either */ - if (!packlen) - { - Perl_croak(aTHX_ "Can't call method \"%"SVf"\" " - "without a package or object reference", - SVfARG(meth)); - } - /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0); - if (!stash) - packsv = sv; - else { - SV* const ref = newSViv(PTR2IV(stash)); - (void)hv_store(PL_stashcache, packname, - packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n", - (void*)stash, SVfARG(sv))); - } - goto fetch; - } - /* it _is_ a filehandle name -- replace with a reference */ - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); - } + gv = gv_fetchmethod_ent(CopSTASH(PL_curcop), &meth_entry, GV_AUTOLOAD|GV_CROAK|GV_SUPER); + assert(gv); - /* if we got here, ob should be an object or a glob */ - if (!ob || !(SvOBJECT(ob) - || (isGV_with_GP(ob) - && (ob = MUTABLE_SV(GvIO((const GV *)ob))) - && SvOBJECT(ob)))) - { - Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference", - SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa")) - ? newSVpvs_flags("DOES", SVs_TEMP) - : meth)); - } + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; +} - stash = SvSTASH(ob); +PP(pp_method_redir) { + dSP; + GV* gv; + HV* stash; + SV* meth = cMETHOPx_meth_sv(PL_op); + SV* rclass = cMETHOPx_rclass_sv(PL_op); + const SVMAP_ENT meth_entry = SVMAP_ENT_SV(meth, cMETHOPx(PL_op)->op_hash); + const SVMAP_ENT rclass_entry = SVMAP_ENT_SV(rclass, cMETHOPx(PL_op)->op_rclass_hash); - fetch: - /* NOTE: stash may be null, hope hv_fetch_ent and - gv_fetchmethod can cope (it seems they can) */ + I32 flags = GV_AUTOLOAD|GV_CROAK; + if (PL_op->op_private & OPpMETHOD_SUPER) flags |= GV_SUPER; - /* shortcut for simple names */ - if (hashp) { - const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp); - if (he) { - gv = MUTABLE_GV(HeVAL(he)); - assert(stash); - if (isGV(gv) && GvCV(gv) && - (!GvCVGEN(gv) || GvCVGEN(gv) - == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) - return MUTABLE_SV(GvCV(gv)); - } - } + PL_methstash = opmethod_stash(cMETHOPx(PL_op), meth); + + stash = gv_stashent(&rclass_entry, 0); + if (!stash) stash = MUTABLE_HV(rclass); - assert(stash || packsv); - gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv), - meth, GV_AUTOLOAD | GV_CROAK); + gv = gv_fetchmethod_ent(stash, &meth_entry, flags); assert(gv); - return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv); + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; } /* diff --git a/pp_proto.h b/pp_proto.h index 73ff532b5c8c..4f77a6e81dfb 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -149,6 +149,8 @@ PERL_CALLCONV OP *Perl_pp_mapwhile(pTHX); PERL_CALLCONV OP *Perl_pp_match(pTHX); PERL_CALLCONV OP *Perl_pp_method(pTHX); PERL_CALLCONV OP *Perl_pp_method_named(pTHX); +PERL_CALLCONV OP *Perl_pp_method_redir(pTHX); +PERL_CALLCONV OP *Perl_pp_method_super(pTHX); PERL_CALLCONV OP *Perl_pp_mkdir(pTHX); PERL_CALLCONV OP *Perl_pp_modulo(pTHX); PERL_CALLCONV OP *Perl_pp_multiply(pTHX); diff --git a/proto.h b/proto.h index 6abd8671464c..1bb7eca07518 100644 --- a/proto.h +++ b/proto.h @@ -748,6 +748,11 @@ PERL_CALLCONV_NO_RET void Perl_croak_xs_usage(const CV *const cv, const char *co #define PERL_ARGS_ASSERT_CROAK_XS_USAGE \ assert(cv); assert(params) +PERL_CALLCONV HV* Perl_curmethod_stash(pTHX_ SV** objptr, CV* sub) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CURMETHOD_STASH \ + assert(objptr) + PERL_CALLCONV regexp_engine const * Perl_current_re_engine(pTHX); PERL_CALLCONV const char * Perl_custom_op_desc(pTHX_ const OP *o) __attribute__warn_unused_result__ @@ -1408,6 +1413,11 @@ PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const ST /* PERL_CALLCONV GV* gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) __attribute__nonnull__(pTHX_2); */ +PERL_CALLCONV GV* Perl_gv_fetchmeth_ent(pTHX_ HV* stash, const SVMAP_ENT* entry, I32 level, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_GV_FETCHMETH_ENT \ + assert(entry) + PERL_CALLCONV GV* Perl_gv_fetchmeth_pv(pTHX_ HV* stash, const char* name, I32 level, U32 flags) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETH_PV \ @@ -1450,13 +1460,19 @@ PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \ assert(stash); assert(name) +PERL_CALLCONV GV* Perl_gv_fetchmethod_ent(pTHX_ HV* stash, const SVMAP_ENT* entry, U32 flags) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_ENT \ + assert(stash); assert(entry) + PERL_CALLCONV GV* Perl_gv_fetchmethod_pv_flags(pTHX_ HV* stash, const char* name, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS \ assert(stash); assert(name) -PERL_CALLCONV GV* Perl_gv_fetchmethod_pvn_flags(pTHX_ HV* stash, const char* name, const STRLEN len, U32 flags) +PERL_CALLCONV GV* Perl_gv_fetchmethod_pvn_flags(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS \ @@ -1537,21 +1553,44 @@ PERL_CALLCONV GV * Perl_gv_override(pTHX_ const char * const name, const STRLEN #define PERL_ARGS_ASSERT_GV_OVERRIDE \ assert(name) +PERL_CALLCONV void Perl_gv_stash_cache_destroy(pTHX); +PERL_CALLCONV void Perl_gv_stash_cache_init(pTHX); +PERL_CALLCONV void Perl_gv_stash_cache_invalidate(pTHX); +PERL_CALLCONV HV* Perl_gv_stashent(pTHX_ const SVMAP_ENT* entry, I32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_STASHENT \ + assert(entry) + +PERL_CALLCONV HV* Perl_gv_stashof_pvn(pTHX_ const char *name, STRLEN len, I32 flags, const svtype sv_type, const char** name_ret, STRLEN *len_ret, GV** gv_ret) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_STASHOF_PVN \ + assert(name) + PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHPV \ assert(name) -PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 flags) +PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, STRLEN namelen, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHPVN \ assert(name) +PERL_CALLCONV void Perl_gv_stashpvn_cache_invalidate(pTHX_ const char* name, STRLEN namelen, I32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_STASHPVN_CACHE_INVALIDATE \ + assert(name) + PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHSV \ assert(sv) +PERL_CALLCONV void Perl_gv_stashsv_cache_invalidate(pTHX_ SV* sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_STASHSV_CACHE_INVALIDATE \ + assert(sv) + PERL_CALLCONV void Perl_gv_try_downgrade(pTHX_ GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE \ @@ -2549,6 +2588,11 @@ PERL_CALLCONV SV* Perl_mess_sv(pTHX_ SV* basemsg, bool consume) #define PERL_ARGS_ASSERT_MESS_SV \ assert(basemsg) +PERL_CALLCONV HV* Perl_method_stash(pTHX_ SV** objptr, SV* meth) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_METHOD_STASH \ + assert(objptr) + PERL_CALLCONV Free_t Perl_mfree(Malloc_t where); PERL_CALLCONV int Perl_mg_clear(pTHX_ SV* sv) __attribute__nonnull__(pTHX_1); @@ -2643,6 +2687,7 @@ PERL_CALLCONV SV* Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, #define PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA \ assert(smeta); assert(which) +PERL_CALLCONV void Perl_mro_global_method_cache_clear(pTHX); PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN \ @@ -2866,6 +2911,17 @@ PERL_CALLCONV OP* Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP* expr, OP* __attribute__malloc__ __attribute__warn_unused_result__; +PERL_CALLCONV OP* Perl_newMETHOP(pTHX_ I32 type, I32 flags, OP* dynamic_meth) + __attribute__malloc__ + __attribute__warn_unused_result__; + +PERL_CALLCONV OP* Perl_newMETHOPnamed(pTHX_ I32 type, I32 flags, SV* const_meth) + __attribute__malloc__ + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_NEWMETHOPNAMED \ + assert(const_meth) + PERL_CALLCONV CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWMYSUB \ @@ -6511,11 +6567,12 @@ STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) #define PERL_ARGS_ASSERT_DO_ODDBALL \ assert(oddkey); assert(firstkey) -STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp) +STATIC HV* S_opmethod_stash(pTHX_ METHOP* op, SV* meth) __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_METHOD_COMMON \ - assert(meth) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_OPMETHOD_STASH \ + assert(op); assert(meth) #endif #if defined(PERL_IN_PP_PACK_C) diff --git a/regen/opcodes b/regen/opcodes index 988b84118ad3..007e03676af7 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -307,8 +307,9 @@ redo redo ck_null ds} dump dump ck_null ds} goto goto ck_null ds} exit exit ck_fun ds% S? -method_named method with known name ck_null d$ - +method_named method with known name ck_null d$ +method_super super method with known name ck_null d$ +method_redir redirect method with known name ck_null d$ entergiven given() ck_null d| leavegiven leave given block ck_null 1 enterwhen when() ck_null d| diff --git a/scope.c b/scope.c index 5cfd78bba66c..90513f9b2d97 100644 --- a/scope.c +++ b/scope.c @@ -264,6 +264,8 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) PERL_ARGS_ASSERT_SAVE_GP; save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); + /* flag to help gv_method_changed and other cache-clearing functions realize that refcnt actually is 1 more than it is because of savestack*/ + GvLOCALIZED_on(gv); if (empty) { GP *gp = Perl_newGP(aTHX_ gv); @@ -838,19 +840,16 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_GVSLOT: /* any slot in GV */ { HV *const hv = GvSTASH(ARG2_GV); - svp = ARG1_SVP; - if (hv && HvENAME(hv) && ( - (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV) - || (*svp && SvTYPE(*svp) == SVt_PVCV) - )) - { - if ((char *)svp < (char *)GvGP(ARG2_GV) - || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp) - || GvREFCNT(ARG2_GV) > 1) - PL_sub_generation++; - else mro_method_changed_in(hv); - } - goto restore_svp; + svp = ARG1_SVP; + if (hv && HvENAME(hv) && ((ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV) || (*svp && SvTYPE(*svp) == SVt_PVCV))) { + /* reference from savestack must be invisible for gv_method_changed! otherwise cache is invalidated globally! */ + if (GvLOCALIZED(ARG2_GV)) --GvREFCNT(ARG2_GV); + if ((char*)svp < (char*)GvGP(ARG2_GV) || (char*)svp > (char*)GvGP(ARG2_GV) + sizeof(GP) || GvREFCNT(ARG2_GV) > 1) + PL_sub_generation++; + else mro_method_changed_in(hv); + if (GvLOCALIZED(ARG2_GV)) ++GvREFCNT(ARG2_GV); + } + goto restore_svp; } case SAVEt_AV: /* array reference */ SvREFCNT_dec(GvAV(ARG1_GV)); @@ -925,6 +924,8 @@ Perl_leave_scope(pTHX_ I32 base) const bool had_method = !!GvCVu(ARG1_GV); gp_free(ARG1_GV); GvGP_set(ARG1_GV, (GP*)ARG0_PTR); + GvLOCALIZED_off(ARG1_GV); + /* reference from savestack must be invisible for gv_method_changed! otherwise cache is invalidated globally! */ if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) { if ( GvNAMELEN(ARG1_GV) == 3 && strnEQ(GvNAME(ARG1_GV), "ISA", 3) @@ -934,7 +935,6 @@ Perl_leave_scope(pTHX_ I32 base) /* putting a method back into circulation ("local")*/ gv_method_changed(ARG1_GV); } - SvREFCNT_dec_NN(ARG1_GV); break; } case SAVEt_FREESV: diff --git a/sv.c b/sv.c index b02ef286d98c..098db4560172 100644 --- a/sv.c +++ b/sv.c @@ -1456,8 +1456,8 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ - DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); - hv_clear(PL_stashcache); + DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); + gv_stash_cache_invalidate(); SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; @@ -3853,13 +3853,12 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); if (GvIO(dstr) && dtype == SVt_PVGV) { - DEBUG_o(Perl_deb(aTHX_ - "glob_assign_glob clearing PL_stashcache\n")); - /* It's a cache. It will rebuild itself quite happily. - It's a lot of effort to work out exactly which key (or keys) - might be invalidated by the creation of the this file handle. - */ - hv_clear(PL_stashcache); + DEBUG_o(Perl_deb(aTHX_ "glob_assign_glob clearing PL_stashcache\n")); + /* It's a cache. It will rebuild itself quite happily. + It's a lot of effort to work out exactly which key (or keys) + might be invalidated by the creation of the this file handle. + */ + gv_stash_cache_invalidate(); } return; } @@ -3967,7 +3966,12 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if(GvSTASH(dstr)) { + /* reference from savestack must be invisible for gv_method_changed! otherwise cache is invalidated globally! */ + if (GvLOCALIZED(dstr)) --GvREFCNT(dstr); + gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if (GvLOCALIZED(dstr)) ++GvREFCNT(dstr); + } } *location = SvREFCNT_inc_simple_NN(sref); if (import_flag && !(GvFLAGS(dstr) & import_flag) @@ -4046,7 +4050,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) It's a lot of effort to work out exactly which key (or keys) might be invalidated by the creation of the this file handle. */ - hv_clear(PL_stashcache); + gv_stash_cache_invalidate(); } break; } @@ -6382,12 +6386,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if ( PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME((HV*)sv))) { - if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", - SVfARG(sv))); - (void)hv_deletehek(PL_stashcache, - HvNAME_HEK((HV*)sv), G_DISCARD); - } + DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", SVfARG(sv))); + gv_stashpvn_cache_invalidate(name, HvNAMELEN((HV*)sv), HvNAMEUTF8((HV*)sv) ? SVf_UTF8 : 0); hv_name_set((HV*)sv, NULL, 0, 0); } @@ -6644,21 +6644,22 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { stash = SvSTASH(sv); assert(SvTYPE(stash) == SVt_PVHV); if (HvNAME(stash)) { + struct mro_meta* meta; CV* destructor = NULL; assert (SvOOK(stash)); if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash); - if (!destructor || HvMROMETA(stash)->destroy_gen - != PL_sub_generation) + meta = HvMROMETA(stash); + if (!destructor || meta->destroy_gen + != meta->cache_gen + meta->pkg_gen + PL_sub_generation) { - GV * const gv = - gv_fetchmeth_autoload(stash, "DESTROY", 7, 0); + /* GV * const gv = gv_fetchmethod_pvn_flags(stash, "DESTROY", 7, GV_AUTOLOAD); */ /* uncomment to support AUTOLOAD for DESTROY */ + GV * const gv = gv_fetchmethod_pvn_flags(stash, "DESTROY", 7, 0); if (gv) destructor = GvCV(gv); if (!SvOBJECT(stash)) { SvSTASH(stash) = destructor ? (HV *)destructor : ((HV *)0)+1; - HvAUX(stash)->xhv_mro_meta->destroy_gen = - PL_sub_generation; + meta->destroy_gen = meta->cache_gen + meta->pkg_gen + PL_sub_generation; } } assert(!destructor || destructor == ((CV *)0)+1 @@ -14043,7 +14044,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param); PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param); - PL_stashcache = newHV(); + gv_stash_cache_init(); + PL_methstash = proto_perl->Imethstash ? hv_dup(proto_perl->Imethstash, param) : NULL; PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, proto_perl->Iwatchaddr); @@ -15009,6 +15011,10 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) } } +#define SVMAP_ENTRY_CMP(l, r) (l->name != r->name && ((l->hash - r->hash) || (l->flags ^ r->flags) || memNE(l->name, r->name, r->len))) +#define SVMAP_ENTRY_HASH(entry) entry->hash +DECLARE_HASHMAP(svmap, SVMAP_ENTRY_CMP, SVMAP_ENTRY_HASH, Safefree, saferealloc); + /* * Local variables: * c-indentation-style: bsd diff --git a/sv.h b/sv.h index 753b5bbeeedd..6607ec12dfbc 100644 --- a/sv.h +++ b/sv.h @@ -586,7 +586,7 @@ typedef U32 cv_flags_t; * compilation) in the lexically enclosing \ * sub */ \ cv_flags_t xcv_flags; \ - I32 xcv_depth /* >= 2 indicates recursive call */ + I32 xcv_depth; /* >= 2 indicates recursive call */ /* This structure must match XPVCV in cv.h */ @@ -2295,6 +2295,26 @@ Evaluates I more than once. Sets I to 0 if C is false. #define SV_CONSTS_COUNT 35 +/* entry for storing SVs in fast C hash (for perl internal needs - caches and so on) */ +struct svmap_entry { + union { + SV* sv; + HV* hv; + GV* gv; + AV* av; + CV* cv; + } value; + U64TYPE hash; + const char* name; + STRLEN len; + U32 flags; +}; + +#define SVMAP_ENT_PVN(name,len,flags,hash) {{NULL}, hash, name, len, flags} +#define SVMAP_ENT_SV(sv,hash) {{NULL}, hash, SvPVX(sv), SvCUR(sv), SvFLAGS(sv) & SVf_UTF8} + +DEFINE_HASHMAP(svmap, SVMAP, SVMAP_ENT); + /* * Local variables: * c-indentation-style: bsd diff --git a/t/op/svleak.t b/t/op/svleak.t index 3b8df477f8dd..8d45f21d99c1 100644 --- a/t/op/svleak.t +++ b/t/op/svleak.t @@ -167,6 +167,7 @@ leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak"); # operator at run time, not compile time, so the values will already be # on the stack before grep starts. my $_3 = 3; + qr/123/; grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter"); diff --git a/universal.c b/universal.c index c219411ed797..397983005dbd 100644 --- a/universal.c +++ b/universal.c @@ -223,7 +223,7 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) PUTBACK; methodname = newSVpvs_flags("isa", SVs_TEMP); - /* ugly hack: use the SvSCREAM flag so S_method_common + /* ugly hack: use the SvSCREAM flag so S_method_stash * can figure out we're calling DOES() and not isa(), * and report eventual errors correctly. --rgs */ SvSCREAM_on(methodname); @@ -350,47 +350,18 @@ XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_can) { dXSARGS; - SV *sv; - SV *rv; - HV *pkg = NULL; - GV *iogv; + dMETHSTASH_NOCROAK; + SV* rv; + if (items != 2) croak_xs_usage(cv, "object-ref, method"); - if (items != 2) - croak_xs_usage(cv, "object-ref, method"); - - sv = ST(0); - - SvGETMAGIC(sv); - - /* Reject undef and empty string. Note that the string form takes - precedence here over the numeric form, as (!1)->foo treats the - invocant as the empty string, though it is a dualvar. */ - if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) - XSRETURN_UNDEF; + if (!stash) XSRETURN_UNDEF; + else if (SvTYPE(stash) != SVt_PVHV) stash = gv_stashpvs("UNIVERSAL", 0); rv = &PL_sv_undef; - if (SvROK(sv)) { - sv = MUTABLE_SV(SvRV(sv)); - if (SvOBJECT(sv)) - pkg = SvSTASH(sv); - else if (isGV_with_GP(sv) && GvIO(sv)) - pkg = SvSTASH(GvIO(sv)); - } - else if (isGV_with_GP(sv) && GvIO(sv)) - pkg = SvSTASH(GvIO(sv)); - else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) - pkg = SvSTASH(GvIO(iogv)); - else { - pkg = gv_stashsv(sv, 0); - if (!pkg) - pkg = gv_stashpvs("UNIVERSAL", 0); - } - - if (pkg) { - GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); - if (gv && isGV(gv)) - rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); + if (stash) { + GV * const gv = gv_fetchmethod_sv_flags(stash, ST(1), 0); + if (gv && isGV(gv)) rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); } ST(0) = rv;