In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/73519bd01829f1480c288a0a7ccbfff973d867df?hp=e7598a06d704c8e12489be3a9098367ae55f5a89>
- Log ----------------------------------------------------------------- commit 73519bd01829f1480c288a0a7ccbfff973d867df Author: Nicholas Clark <[email protected]> Date: Thu Aug 20 16:02:40 2009 +0100 Optimise S_mro_get_linear_isa_dfs() when dealing with the first parent class. Benchmarking with single inheritance suggests that this is 10% faster. M MANIFEST M mro.c A t/mro/isa_dfs.t commit c3acb9e0760135dfd888c0ee1b415777d784aabc Author: Nicholas Clark <[email protected]> Date: Thu Aug 20 15:56:18 2009 +0100 Perl_newHVhv() should copy immortal values as-is, such as PL_sv_undef Currently it calls newSVsv() always, which copies the value, but the immortal SVs are used as much for their addresses as their values. You can't get the immortals into HVs from Perl-space, except for PL_sv_placeholder, and any hash with those will take the else block, where the call to Perl_hv_iternext_flags() won't be returning placeholders anyway. Hence If XS code has gone to the trouble to get the "impossible" in there, they had a reason for it. I am assuming that Perl_hv_copy_hints_hv() should stay as-is, as it is documented that only strings and integers are supported values for %^H. M hv.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + hv.c | 8 +++-- mro.c | 102 +++++++++++++++++++++++++++++++++++++------------------ t/mro/isa_dfs.t | 53 ++++++++++++++++++++++++++++ 4 files changed, 128 insertions(+), 36 deletions(-) create mode 100644 t/mro/isa_dfs.t 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/hv.c b/hv.c index a5221a8..ee3a67e 100644 --- a/hv.c +++ b/hv.c @@ -1379,8 +1379,9 @@ Perl_newHVhv(pTHX_ HV *ohv) const STRLEN len = HeKLEN(oent); const int flags = HeKFLAGS(oent); HE * const ent = new_HE(); + SV *const val = HeVAL(oent); - HeVAL(ent) = newSVsv(HeVAL(oent)); + HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) : save_hek_flags(key, len, hash, flags); @@ -1411,9 +1412,10 @@ Perl_newHVhv(pTHX_ HV *ohv) hv_iterinit(ohv); while ((entry = hv_iternext_flags(ohv, 0))) { + SV *const val = HeVAL(entry); (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), - newSVsv(HeVAL(entry)), HeHASH(entry), - HeKFLAGS(entry)); + SvIMMORTAL(val) ? val : newSVsv(val), + HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); 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); + } +} -- Perl5 Master Repository
