From: Nicholas Clark Date: Thu, 20 Aug 2009 15:02:40 +0000 (+0100) Subject: Optimise S_mro_get_linear_isa_dfs() when dealing with the first parent class. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=73519bd01829f1480c288a0a7ccbfff973d867df;p=p5sagit%2Fp5-mst-13.2.git Optimise S_mro_get_linear_isa_dfs() when dealing with the first parent class. Benchmarking with single inheritance suggests that this is 10% faster. --- diff --git a/MANIFEST b/MANIFEST index 116829a..9cc4b3a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4130,6 +4130,7 @@ t/mro/complex_dfs.t mro tests t/mro/dbic_c3.t mro tests t/mro/dbic_dfs.t mro tests t/mro/inconsistent_c3.t mro tests +t/mro/isa_dfs.t test for optimisatised mro_get_linear_isa_dfs t/mro/method_caching.t mro tests t/mro/next_edgecases.t mro tests t/mro/next_goto.t mro tests diff --git a/mro.c b/mro.c index 23f8c07..7131593 100644 --- a/mro.c +++ b/mro.c @@ -211,7 +211,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) const HEK* stashhek; struct mro_meta* meta; SV *our_name; - HV *stored; + HV *stored = NULL; PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; assert(HvAUX(stash)); @@ -249,8 +249,6 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) It's then retained to be re-used as a fast lookup for ->isa(), by adding our own name and "UNIVERSAL" to it. */ - stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - if(av && AvFILLp(av) >= 0) { SV **svp = AvARRAY(av); @@ -281,41 +279,79 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) subrv_p = AvARRAY(subrv); subrv_items = AvFILLp(subrv) + 1; } - while(subrv_items--) { - SV *const subsv = *subrv_p++; - /* LVALUE fetch will create a new undefined SV if necessary - */ - HE *const he = hv_fetch_ent(stored, subsv, 1, 0); - assert(he); - if(HeVAL(he) != &PL_sv_undef) { - /* It was newly created. Steal it for our new SV, and - replace it in the hash with the "real" thing. */ - SV *const val = HeVAL(he); - HEK *const key = HeKEY_hek(he); - - HeVAL(he) = &PL_sv_undef; - /* Save copying by making a shared hash key scalar. We - inline this here rather than calling Perl_newSVpvn_share - because we already have the scalar, and we already have - the hash key. */ - assert(SvTYPE(val) == SVt_NULL); - sv_upgrade(val, SVt_PV); - SvPV_set(val, HEK_KEY(share_hek_hek(key))); - SvCUR_set(val, HEK_LEN(key)); - SvREADONLY_on(val); - SvFAKE_on(val); - SvPOK_on(val); - if (HEK_UTF8(key)) - SvUTF8_on(val); - - av_push(retval, val); + if (stored) { + while(subrv_items--) { + SV *const subsv = *subrv_p++; + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE *const he = hv_fetch_ent(stored, subsv, 1, 0); + assert(he); + if(HeVAL(he) != &PL_sv_undef) { + /* It was newly created. Steal it for our new SV, and + replace it in the hash with the "real" thing. */ + SV *const val = HeVAL(he); + HEK *const key = HeKEY_hek(he); + + HeVAL(he) = &PL_sv_undef; + /* Save copying by making a shared hash key scalar. We + inline this here rather than calling + Perl_newSVpvn_share because we already have the + scalar, and we already have the hash key. */ + assert(SvTYPE(val) == SVt_NULL); + sv_upgrade(val, SVt_PV); + SvPV_set(val, HEK_KEY(share_hek_hek(key))); + SvCUR_set(val, HEK_LEN(key)); + SvREADONLY_on(val); + SvFAKE_on(val); + SvPOK_on(val); + if (HEK_UTF8(key)) + SvUTF8_on(val); + + av_push(retval, val); + } } - } + } else { + /* We are the first (or only) parent. We can short cut the + complexity above, because our @ISA is simply us prepended + to our parent's @ISA, and our ->isa cache is simply our + parent's, with our name added. */ + /* newSVsv() is slow. This code is only faster if we can avoid + it by ensuring that SVs in the arrays are shared hash key + scalar SVs, because we can "copy" them very efficiently. + Although to be fair, we can't *ensure* this, as a reference + to the internal array is returned by mro::get_linear_isa(), + so we'll have to be defensive just in case someone faffed + with it. */ + if (basestash) { + SV **svp; + stored = MUTABLE_HV(sv_2mortal(newHVhv(HvMROMETA(basestash)->isa))); + av_extend(retval, subrv_items); + AvFILLp(retval) = subrv_items; + svp = AvARRAY(retval); + while(subrv_items--) { + SV *const val = *subrv_p++; + *++svp = SvIsCOW_shared_hash(val) + ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) + : newSVsv(val); + } + } else { + /* They have no stash. So create ourselves an ->isa cache + as if we'd copied it from what theirs should be. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); + av_push(retval, + newSVhek(HeKEY_hek(hv_store_ent(stored, sv, + &PL_sv_undef, 0)))); + } + } } + } else { + /* We have no parents. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); } (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); - (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); SvREFCNT_inc_simple_void_NN(stored); SvTEMP_off(stored); diff --git a/t/mro/isa_dfs.t b/t/mro/isa_dfs.t new file mode 100644 index 0000000..6eabf1f --- /dev/null +++ b/t/mro/isa_dfs.t @@ -0,0 +1,53 @@ +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require "./test.pl"; +} + +use strict; + +plan 'no_plan'; + +# package klonk doesn't have a stash. + +package kapow; + +# No parents + +package urkkk; + +# 1 parent +@urkkk::ISA = 'klonk'; + +package kayo; + +# 2 parents +@urkkk::ISA = ('klonk', 'kapow'); + +package thwacke; + +# No parents, has @ISA +@thwacke::ISA = (); + +package zzzzzwap; + +@zzzzzwap::ISA = ('thwacke', 'kapow'); + +package whamm; + +@whamm::ISA = ('kapow', 'thwacke'); + +package main; + +require mro; + +foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) { + my $ref = bless [], $package; + my $isa = mro::get_linear_isa($package); + + foreach my $class ($package, @$isa, 'UNIVERSAL') { + isa_ok($ref, $class, $package); + } +}