From: gfx Date: Fri, 28 Aug 2009 09:59:34 +0000 (+0900) Subject: Reconsider method generation X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e192207ea83053f92a07fb2ee60cec71d51f8249;p=gitmo%2FClass-MOP.git Reconsider method generation --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index fab25e0..0b3f837 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -502,9 +502,7 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; - my $cloned = $self->meta->clone_object($self, @_); - $cloned->BUILD(); - return $cloned; + return $self->meta->clone_object($self, @_); }); ## -------------------------------------------------------- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 8331b4b..5b2fab5 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -52,9 +52,7 @@ sub new { confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); } - my $self = $class->_new(\%options); - $self->BUILD(); # Initializer in XS - return $self; + return $class->_new(\%options); } sub _new { @@ -100,9 +98,7 @@ sub clone { my %options = @_; (blessed($self)) || confess "Can only clone an instance"; - my $cloned = bless { %{$self}, %options } => ref($self); - $cloned->BUILD(); - return $cloned; + return bless { %{$self}, %options } => ref($self); } sub initialize_instance_slot { diff --git a/mop.h b/mop.h index 688cbb7..2d5086b 100644 --- a/mop.h +++ b/mop.h @@ -83,6 +83,13 @@ typedef struct { void (*weaken_slot) (pTHX_ SV* const mi, SV* const instance); } mop_instance_vtbl; +SV* mop_instance_create_instance(pTHX_ HV* const stash); +bool mop_instance_has_slot(pTHX_ SV* const instance, SV* const slot); +SV* mop_instance_get_slot(pTHX_ SV* const instance, SV* const slot); +SV* mop_instance_set_slot(pTHX_ SV* const instance, SV* const slot, SV* const value); +SV* mop_instance_delete_slot(pTHX_ SV* const instance, SV* const slot); +void mop_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot); + const mop_instance_vtbl* mop_get_default_instance_vtbl(pTHX); #define MOP_mg_obj(mg) ((mg)->mg_obj) @@ -114,7 +121,7 @@ MAGIC* mop_attr_get_mg(pTHX_ SV* const attr); SV* mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv); -MAGIC* mop_accessor_get_mg(pTHX_ CV* const cv); +MAGIC* mop_attr_get_mg(pTHX_ SV* const attr); CV* mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSUBADDR_t const accessor_impl, const mop_instance_vtbl* vtbl); CV* mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSUBADDR_t const accessor_impl, mop_instance_vtbl* const vtbl); diff --git a/xs/Attribute.xs b/xs/Attribute.xs index ca2c4fb..157b7be 100644 --- a/xs/Attribute.xs +++ b/xs/Attribute.xs @@ -1,15 +1,5 @@ #include "mop.h" -static MGVTBL mop_attr_vtbl; - - -MAGIC* -mop_attr_get_mg(pTHX_ SV* const attr){ - if(!SvROK(attr)) croak("Invalid object"); - - return mop_mg_find(aTHX_ SvRV(attr), &mop_attr_vtbl, MOPf_DIE_ON_FAIL); -} - MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute @@ -42,13 +32,3 @@ BOOT: INSTALL_SIMPLE_PREDICATE(Attribute, initializer); INSTALL_SIMPLE_PREDICATE(Attribute, default); -void -BUILD(SV* self) -PREINIT: - mop_instance_vtbl* vtbl; -CODE: - if(!( SvROK(self) && SvOBJECT(SvRV(self)) )){ - croak("Invalid object"); - } - sv_magicext(SvRV(self), NULL, PERL_MAGIC_ext, &mop_attr_vtbl, NULL, 0); - diff --git a/xs/Class.xs b/xs/Class.xs index d779683..a9de7be 100644 --- a/xs/Class.xs +++ b/xs/Class.xs @@ -1,80 +1,15 @@ #include "mop.h" -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; - SV *coderef; - HV *symbols; - dSP; +#define _generate_constructor_method_xs(self, vtbl) mop_generate_constructor_method_xs(aTHX_ self, (mop_instance_vtbl*)vtbl) - symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE); - sv_2mortal((SV*)symbols); - (void)hv_iterinit(symbols); - while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) { - CV *cv = (CV *)SvRV(coderef); - char *cvpkg_name; - char *cv_name; - SV *method_slot; - SV *method_object; +static MGVTBL mop_constructor_vtbl; - if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) { - continue; - } +static CV* +mop_generate_constructor_method_xs(pTHX_ SV* const metaclass, mop_instance_vtbl* const instance_vtbl){ + // CV* const xsub = newXS(NULL, mop_xs_constructor, __FILE__); - /* 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; - } - } + assert(instance_vtbl); - method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); - if ( SvOK(method_slot) ) { - SV *const body = mop_call0(aTHX_ method_slot, mop_body); /* $method_object->body() */ - if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { - continue; - } - } - - method_metaclass_name = mop_call0(aTHX_ self, mop_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(mop_associated_metaclass); - PUSHs(self); - PUSHs(mop_package_name); - PUSHs(class_name); - PUSHs(mop_name); - mPUSHs(newSVpv(method_name, method_name_len)); - PUTBACK; - - call_sv(mop_wrap, G_SCALAR | G_METHOD); - SPAGAIN; - method_object = POPs; - PUTBACK; - /* $map->{$method_name} = $method_object */ - sv_setsv(method_slot, method_object); - - FREETMPS; - LEAVE; - } } MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class @@ -91,39 +26,5 @@ BOOT: INSTALL_SIMPLE_READER(Class, constructor_class); INSTALL_SIMPLE_READER(Class, destructor_class); - -PROTOTYPES: DISABLE - -void -get_method_map(self) - SV *self - PREINIT: - HV *const obj = (HV *)SvRV(self); - SV *const class_name = HeVAL( hv_fetch_ent(obj, mop_package, 0, 0U) ); - HV *const stash = gv_stashsv(class_name, 0); - UV current; - SV *cache_flag; - SV *map_ref; - PPCODE: - if (!stash) { - mXPUSHs(newRV_noinc((SV *)newHV())); - return; - } - - current = mop_check_package_cache_flag(aTHX_ stash); - cache_flag = HeVAL( hv_fetch_ent(obj, mop_package_cache_flag, TRUE, 0U)); - map_ref = HeVAL( hv_fetch_ent(obj, mop_methods, TRUE, 0U)); - - /* $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 ) { - mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref)); - sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */ - } - - XPUSHs(map_ref); +CV* +_generate_constructor_method_xs(SV* self, void* instance_vtbl) diff --git a/xs/Instance.xs b/xs/Instance.xs index d378c91..18c9c27 100644 --- a/xs/Instance.xs +++ b/xs/Instance.xs @@ -9,13 +9,13 @@ } \ } STMT_END -static SV* +SV* mop_instance_create_instance(pTHX_ HV* const stash) { assert(stash); return sv_bless( newRV_noinc((SV*)newHV()), stash ); } -static bool +bool mop_instance_has_slot(pTHX_ SV* const instance, SV* const slot) { assert(instance); assert(slot); @@ -23,7 +23,7 @@ mop_instance_has_slot(pTHX_ SV* const instance, SV* const slot) { return hv_exists_ent((HV*)SvRV(instance), slot, 0U); } -static SV* +SV* mop_instance_get_slot(pTHX_ SV* const instance, SV* const slot) { HE* he; assert(instance); @@ -33,7 +33,7 @@ mop_instance_get_slot(pTHX_ SV* const instance, SV* const slot) { return he ? HeVAL(he) : NULL; } -static SV* +SV* mop_instance_set_slot(pTHX_ SV* const instance, SV* const slot, SV* const value) { HE* he; SV* sv; @@ -47,7 +47,7 @@ mop_instance_set_slot(pTHX_ SV* const instance, SV* const slot, SV* const value) return sv; } -static SV* +SV* mop_instance_delete_slot(pTHX_ SV* const instance, SV* const slot) { assert(instance); assert(slot); @@ -55,7 +55,7 @@ mop_instance_delete_slot(pTHX_ SV* const instance, SV* const slot) { return hv_delete_ent((HV*)SvRV(instance), slot, 0, 0U); } -static void +void mop_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot) { HE* he; assert(instance); diff --git a/xs/MOP.xs b/xs/MOP.xs index 4c89372..8c936df 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -31,7 +31,7 @@ mop_is_instance_of(pTHX_ SV* const sv, SV* const klass){ FREETMPS; LEAVE; - return FALSE; + return ok; } return FALSE; diff --git a/xs/MethodAccessor.xs b/xs/MethodAccessor.xs index 57c484c..c5b99e0 100644 --- a/xs/MethodAccessor.xs +++ b/xs/MethodAccessor.xs @@ -55,16 +55,20 @@ mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSUBADDR_t const accessor_ STRLEN klen; const char* const kpv = SvPV_const(key, klen); + SV* const keysv = newSVpvn_share(kpv, klen, 0U); - MAGIC* mg = mop_attr_get_mg(aTHX_ attr); + MAGIC* mg; CV* const xsub = newXS(NULL, accessor_impl, __FILE__); sv_2mortal((SV*)xsub); - MOP_mg_obj(mg) = newSVpvn_share(kpv, klen, 0U); - MOP_mg_obj_refcounted_on(mg); + mg = sv_magicext((SV*)xsub, keysv, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0); + SvREFCNT_dec(keysv); /* sv_magicext() increases refcnt in mg_obj */ - CvXSUBANY(xsub).any_ptr = sv_magicext((SV*)xsub, MOP_mg_obj(mg), PERL_MAGIC_ext, MOP_mg_virtual(mg), (char*)vtbl, 0); + /* NOTE: + * although we use MAGIC for gc, we also store mg to CvXSUBANY slot for efficiency (gfx) + */ + CvXSUBANY(xsub).any_ptr = mg; return xsub; }