From 1652f10c5381eb14fc5434b0750ce1448b1f82f8 Mon Sep 17 00:00:00 2001 From: syber Date: Thu, 24 Jul 2014 23:07:23 +0400 Subject: [PATCH] Large commit with very significant speedup of class/object method calls and several more features: 1) Added hashmap.h - extremely fast low-level C hash to use for perl code needs (see below). 2) Speeding up stash cache, make gv_stash* use the cache and by this make all of perl core and XS modules use this cache, not only S_method_common. - Change PL_stashcache from HV* to SVMAP* (hashmap of SVMAP_ENT values) - The lowest-level function is now gv_stashent which receives precomputed hash64 value for class name and searches the cache. If nothing found, calls slow S_gv_stashpvn (former Perl_gv_stashpvn) and fills the cache. - gv_stashpvn is now a wrapper for gv_stashent, computing hash value. - add API functions to clear stash cache locally (1 class) and globally. Make use of them. - added one more flag to gv_stash* - GV_CACHE_ONLY which returns stash only if found in cache, otherwise NULL. Required for correct behaviour of rule "IO globs take precedence over class names". - use private hash function PERL_HASH64 for computing hash values for class names. This function is much faster than PERL_HASH function (especially for long keys, which is likely for full class names) and returns a 64bit value. It doesn't use randomization because stash cache is a private core data, not a user data. 3) Speeding up method cache and super method cache, make gv_fetchmeth*/gv_fetchmethod* use the cache. - store method cache in meta->mro_method instead of package stash's HV itself. - rename meta->mro_super -> meta->mro_supermethod - meta->mro_method & meta->mro_supermethod are both SVMAP* - The lowest-level function for gv_fetchmeth* is now gv_fetchmeth_ent which receives precomputed hash value for method name. - gv_fetchmeth_pvn is now a wrapper for gv_fetchmeth_ent, computing hash64 value. - The lowest-level function for gv_fetchmethod* is now gv_fetchmethod_ent which receives precomputed hash value for method name. Method cannot contain '::', gv_fetchmethod_ent doesn't search for '::'. - gv_fetchmethod_pvn is now a wrapper for gv_fetchmethod_ent, searching for '::', changing method name (and possibly stash, flags) and computing hash64 value. - new flag for gv_fetchmethod_pvn - GV_METHOD_SIMPLE, which means gv_fetchmethod_pvn doesn't need to scan for '::' in method name. 4) Precomputing hash64 values for perl code. - added 2 more op types: - OP_METHOD_SUPER "$proto->SUPER::func()" - OP_METHOD_REDIR "$proto->OtherClass::func()" or "$proto->OtherClass::SUPER::func()" - added new op struct type - struct methop (typedef METHOP). It actually behaves like UNOP for OP_METHOD and like SVOP for OP_METHOD_* and fully compatible with them for backward compability. It contains additional fields: - hash for method name (for OP_METHOD_*). Method name SV and targ are still in ->op_sv and ->op_targ - hash, sv and targ for class name (for all types) - hash, sv and targ for redirect class name (for OP_METHOD_REDIR) - ck_method detects const method name, fills hash and sv, and creates OP_METHOD_NAMED - ck_method detects const method name with SUPER keyword, fills hash and sv, and creates OP_METHOD_SUPER - ck_method detects const method name with class redirect (possibly with SUPER keyword), fills hash, sv, rclass hash and rclass sv and creates OP_METHOD_REDIR - ck_subr now detects if left operand is a const (MyClass->method()), and stores the data (class hash and sv) in underlying OP_METHOD* op. - all of these infos are used in runtime to greatly speedup pp_method* calls 5) OOP context for XSUBs. Calculated stash HV of left operand (object/class/IO/etc) is now saved in PL_methstash for later use by XSUBS. This prevents double caclucation of stash's HV for such functions as UNIVERSAL::can and so on and speeds up them a lot. Moreover it has one more usage: pp_entersub sets PL_methstash to NULL if CV is called as function, and sets PL_methstash to object/class/IO/etc stash's HV if CV is called as class/object/etc method. This makes it possible for XS code to detect if it is called as funtion or method in case if user wants to implement separate behaviour for those cases. For example if (PL_methstash) { ... called as method, object/class/etc stash is in PL_methstash } else { ... called as function } Additionaly for XSUBs like UNIVERSAL::can which always want to interpret its calls as method calls (i.e. first arg is object/class/etc), there is a macro dMETHSTASH which defines variable 'HV* stash' and either sets it to PL_methstash (if called as method) or (if called as function) calculate stash in the same way as pp_method* would do in case of real method call. Note that PL_methstash is not stacked (to not introduce any overheat), that means you have to either use it before you made a new perl CV call or save it to a variable. 6) Bring B, B::Deparse and B::Concise in consistency with new ops. 7) misc: - bugfix in Opcode.xs: _safe_call_sv (and therefore module Safe) had critical vulnerability which made it possible for code in $safe->reval("...") to hack your entire program. - Remove "local's" unneccesary overheat. ("local GLOB = GLOB" - OK, "local GLOB = CODEREF" - OVERHEAT) { local *MyClass::func = sub {...}; # LINE A ... } # LINE B This example caused global method cache reset at both lines A and B because glob_assign_ref and leave_scope thought that GV's GP refcnt was 2 (because of saving to Save Stack). Issue has been fixed (added gp_flags and new GP flag LOCALIZED, if flag is set then 1 refcnt from save stack is not counted in gv_method_changed calls). - bugfix in dump.c : sv_dump(stash) (where stash is HV* - someone's stash) crashes if stash has cached destructor - sv_dump thought that it was a stash and tried to dump CV* as HV*. - UNIVERSAL::can (in universal.c) is rewritten to make use of PL_methstash and runs much faster now. --- AUTHORS | 1 + MANIFEST | 1 + dump.c | 6 +- embed.fnc | 21 +- embed.h | 16 +- embedvar.h | 1 + ext/B/B.xs | 32 ++ ext/B/B/Concise.pm | 5 +- ext/B/t/concise-xs.t | 1 + ext/Opcode/Opcode.pm | 5 +- ext/Opcode/Opcode.xs | 5 +- ext/XS-APItest/t/gv_fetchmeth.t | 5 +- ext/XS-APItest/t/gv_fetchmeth_autoload.t | 5 +- gv.c | 672 ++++++++++++++--------- gv.h | 14 +- hashmap.h | 285 ++++++++++ hv.c | 52 +- hv.h | 14 +- hv_func.h | 46 ++ intrpvar.h | 4 +- lib/B/Deparse.pm | 36 +- lib/overload.t | 5 +- mro.c | 65 ++- op.c | 247 +++++++-- op.h | 70 ++- opcode.h | 10 + opnames.h | 358 ++++++------ perl.c | 45 +- perl.h | 7 + perly.act | 10 +- perly.h | 2 +- perly.tab | 2 +- perly.y | 8 +- pp.h | 3 + pp_ctl.c | 1 + pp_hot.c | 292 +++++----- pp_proto.h | 2 + proto.h | 69 ++- regen/opcodes | 5 +- scope.c | 28 +- sv.c | 54 +- sv.h | 22 +- t/op/svleak.t | 1 + universal.c | 47 +- 44 files changed, 1763 insertions(+), 817 deletions(-) create mode 100644 hashmap.h 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;