From: Dave Rolsky Date: Wed, 3 Dec 2008 03:27:51 +0000 (+0000) Subject: This is a tweaked version of Goro Fuji's XS implementation of X-Git-Tag: 0.71_01~24 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c94afdc4ebe552a2e1da78415d0e366516349a8e;p=gitmo%2FClass-MOP.git This is a tweaked version of Goro Fuji's XS implementation of get_method_map. Tweaks were done for style, and some implementation issues based on comments from rafl. It seems to be about 3x faster when rebuilding the map, though if the map doesn't need rebuilding, the speed difference is trivial. --- diff --git a/MOP.xs b/MOP.xs index cc532e1..a1478fa 100644 --- a/MOP.xs +++ b/MOP.xs @@ -1,4 +1,3 @@ - #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -19,6 +18,137 @@ U32 hash_package_name; SV *key_body; U32 hash_body; +SV* method_metaclass; +SV* associated_metaclass; +SV* wrap; + + +#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash) +#ifdef HvMROMETA /* 5.10.0 */ + +#ifndef mro_meta_init +#define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */ +#endif /* !mro_meta_init */ + +static UV +mop_check_package_cache_flag(pTHX_ HV* stash) { + assert(SvTYPE(stash) == SVt_PVHV); + + return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */ +} + +#else /* pre 5.10.0 */ + +static UV +mop_check_package_cache_flag(pTHX_ HV* stash) { + PERL_UNUSED_ARG(stash); + assert(SvTYPE(stash) == SVt_PVHV); + + return PL_sub_generation; +} +#endif + +#define call0(s, m) mop_call0(aTHX_ s, m) +static SV* +mop_call0(pTHX_ SV* const self, SV* const method) { + dSP; + SV* ret; + + PUSHMARK(SP); + XPUSHs(self); + PUTBACK; + + call_sv(method, G_SCALAR | G_METHOD); + + SPAGAIN; + ret = POPs; + PUTBACK; + + return ret; +} + +static void +mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) { + const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */ + SV* method_metaclass_name; + char* method_name; + I32 method_name_len; + GV* gv; + dSP; + + hv_iterinit(stash); + while((gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len))) { + CV* cv; + if ( SvROK(gv) ) { + /* rafl says that this wastes memory savings that GvSVs have + in 5.8.9 and 5.10.x. But without it some tests fail. rafl + says the right thing to do is to handle GvSVs differently + here. */ + gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI); + } + + if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) { + GV* const cvgv = CvGV(cv); + /* ($cvpkg_name, $cv_name) = get_code_info($cv) */ + const char* const cvpkg_name = HvNAME(GvSTASH(cvgv)); + const char* const cv_name = GvNAME(cvgv); + SV* method_slot; + SV* method_object; + + /* this checks to see that the subroutine is actually from our package */ + if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) { + if ( strNE(cvpkg_name, class_name_pv) ) { + continue; + } + } + + method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); + if ( SvOK(method_slot) ) { + SV* const body = call0(method_slot, key_body); /* $method_object->body() */ + if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) { + continue; + } + } + + method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */ + + /* + $method_object = $method_metaclass->wrap( + $cv, + associated_metaclass => $self, + package_name => $class_name, + name => $method_name + ); + */ + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 8); + PUSHs(method_metaclass_name); /* invocant */ + mPUSHs(newRV_inc((SV*)cv)); + PUSHs(associated_metaclass); + PUSHs(self); + PUSHs(key_package_name); + PUSHs(class_name); + PUSHs(key_name); + mPUSHs(newSVpv(method_name, method_name_len)); + PUTBACK; + + call_sv(wrap, G_SCALAR | G_METHOD); + SPAGAIN; + method_object = POPs; + PUTBACK; + /* $map->{$method_name} = $method_object */ + sv_setsv(method_slot, method_object); + + FREETMPS; + LEAVE; + } + } +} + + /* get_code_info: Pass in a coderef, returns: @@ -39,6 +169,10 @@ BOOT: PERL_HASH(hash_package, "package", 7); PERL_HASH(hash_package_name, "package_name", 12); + method_metaclass = newSVpvs("method_metaclass"); + wrap = newSVpvs("wrap"); + associated_metaclass = newSVpvs("associated_metaclass"); + PROTOTYPES: ENABLE @@ -50,7 +184,7 @@ get_code_info(coderef) char* name; char* pkg; PPCODE: - if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){ + if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) { coderef = SvRV(coderef); /* I think this only gets triggered with a mangled coderef, but if we hit it without the guard, we segfault. The slightly odd return @@ -248,3 +382,40 @@ body(self) XPUSHs(HeVAL(he)); else ST(0) = &PL_sv_undef; + + +MODULE = Class::MOP PACKAGE = Class::MOP::Class + +void +get_method_map(self) + SV* self +INIT: + if ( !SvRV(self) ) { + die("Cannot call get_method_map as a class method"); + } +CODE: + HE* const he = hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package); /* $self->name() */ + SV* const class_name = HeVAL(he); + HV* const stash = gv_stashsv(class_name, TRUE); + UV const current = check_package_cache_flag(stash); + SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE); + SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE); + + /* in $self->{methods} does not yet exist (or got deleted) */ + if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) { + SV* new_map_ref = newRV_noinc((SV*)newHV()); + sv_2mortal(new_map_ref); + sv_setsv(map_ref, new_map_ref); + } + + if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) { + ENTER; + SAVETMPS; + + mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref)); + sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */ + + FREETMPS; + LEAVE; + } + ST(0) = map_ref; /* map_ref is already mortal */