Author: timbo
Date: Tue Feb 7 14:36:52 2012
New Revision: 15132
Added:
dbi/trunk/t/31methcache.t
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/dbixs_rev.h
Log:
speeding up XS_DBI_dispatch patch from Dave Mitchell
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Feb 7 14:36:52 2012
@@ -11,6 +11,7 @@
Fixed compiler warnings in Driver_xst.h (Martin J. Evans)
Fixed compiler warning in DBI.xs (H.Merijn Brand)
+ Significantly optimized method dispatch (Dave Mitchell)
Corrected typo in example in docs (David Precious)
Added note that calling clone() without an arg may warn in future.
Minor changes to the install_method() docs in DBI::DBD.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Feb 7 14:36:52 2012
@@ -84,6 +84,9 @@
static I32 dbi_hash _((const char *string, long i));
static void dbih_dumphandle _((pTHX_ SV *h, const char *msg, int level));
static int dbih_dumpcom _((pTHX_ imp_xxh_t *imp_xxh, const char *msg, int
level));
+static int method_cache_free(pTHX_ SV* sv, MAGIC* mg);
+static int method_cache_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param);
+static GV* inner_method_lookup(pTHX_ HV *stash, CV *cv, const char
*meth_name);
char *neatsvpv _((SV *sv, STRLEN maxlen));
SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void
*foo);
@@ -164,6 +167,115 @@
/* 32 bit magic FNV-0 and FNV-1 prime */
#define FNV_32_PRIME ((UV)0x01000193)
+
+
+/* ext magic attached to outer CV methods to quickly locate the
+ * corresponding inner method
+ */
+
+static MGVTBL method_cache_vtbl = { 0, 0, 0, 0, method_cache_free,
+ 0, method_cache_dup
+#if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION >= 9))
+ , 0
+#endif
+ };
+
+typedef struct {
+ HV *stash; /* the stash we found the GV in */
+ GV *gv; /* the GV containing the inner sub */
+ U32 generation; /* cache invalidation */
+} method_cache_t;
+
+static int method_cache_free(pTHX_ SV* sv, MAGIC* mg)
+{
+ method_cache_t *c = (method_cache_t *)(mg->mg_ptr);
+ SvREFCNT_dec(c->stash);
+ SvREFCNT_dec(c->gv);
+ Safefree(c);
+ return 0;
+}
+
+static int method_cache_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param)
+{
+ method_cache_t *c;
+ Newxc(mg->mg_ptr, 1, method_cache_t, char);
+ c = (method_cache_t *)(mg->mg_ptr);
+ c->stash = NULL;
+ c->gv = NULL;
+ return 0;
+}
+
+static GV* inner_method_lookup(pTHX_ HV *stash, CV *cv, const char *meth_name)
+{
+ GV *gv;
+ method_cache_t *c;
+ MAGIC *mg = SvMAGIC(cv);
+
+ if (mg) {
+ if (mg->mg_virtual != &method_cache_vtbl) {
+ /* usually cache is the first magic in the list;
+ * if not, find it and bump it to the top */
+ MAGIC *nmg = mg->mg_moremagic;
+ while (nmg) {
+ if (nmg->mg_virtual == &method_cache_vtbl)
+ break;
+ mg = nmg;
+ nmg = mg->mg_moremagic;
+ }
+ if (nmg) {
+ mg->mg_moremagic = nmg->mg_moremagic;
+ nmg->mg_moremagic = SvMAGIC(cv);
+ SvMAGIC(cv) = nmg;
+ mg = nmg;
+ }
+ else {
+ mg = NULL;
+ goto no_match;
+ }
+ }
+
+ if ( (c=(method_cache_t *)(mg->mg_ptr))
+ && c->stash == stash
+ && c->generation == PL_sub_generation
+#ifdef HvMROMETA /*introduced in 5.9.5 */
+ + HvMROMETA(stash)->cache_gen
+#endif
+ )
+ return c->gv;
+
+ /* clear stale cache */
+ SvREFCNT_dec(c->stash);
+ SvREFCNT_dec(c->gv);
+ c->stash = NULL;
+ c->gv = NULL;
+ }
+
+ no_match:
+ gv = gv_fetchmethod_autoload(stash, meth_name, FALSE);
+ if (!gv)
+ return NULL;
+
+ /* create new cache entry */
+ if (!mg) {
+ Newx(c, 1, method_cache_t);
+ mg = sv_magicext((SV*)cv, NULL, DBI_MAGIC, &method_cache_vtbl,
+ (char *)c, 0);
+ mg->mg_flags |= MGf_DUP;
+ }
+ SvREFCNT_inc(stash);
+ SvREFCNT_inc(gv);
+ c->stash = stash;
+ c->gv = gv;
+ c->generation = PL_sub_generation
+#ifdef HvMROMETA
+ + HvMROMETA(stash)->cache_gen
+#endif
+ ;
+ return gv;
+}
+
+
+
/* --- make DBI safe for multiple perl interpreters --- */
/* Contributed by Murray Nesbitt of ActiveState */
/* (This pre-dates, and should be replaced by, MY_CTX) */
@@ -3007,6 +3119,7 @@
int call_depth;
int is_nested_call;
NV profile_t1 = 0.0;
+ int is_orig_method_name = 1;
const char *meth_name = GvNAME(CvGV(cv));
const dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
@@ -3182,6 +3295,7 @@
croak("%s->%s() invalid redirect method name %s",
neatsvpv(h,0), meth_name,
neatsvpv(meth_name_sv,0));
meth_name = SvPV_nolen(meth_name_sv);
+ is_orig_method_name = 0;
}
if (ima_flags & IMA_KEEP_ERR)
keep_error = TRUE;
@@ -3421,7 +3535,12 @@
}
}
- imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
meth_name, FALSE);
+ if (is_orig_method_name)
+ imp_msv = (SV*)inner_method_lookup(aTHX_ DBIc_IMP_STASH(imp_xxh),
+ cv, meth_name);
+ else
+ imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
+ meth_name, FALSE);
/* if method was a 'func' then try falling back to real 'func' method
*/
if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) {
@@ -3463,7 +3582,7 @@
PerlIO_flush(logfp);
}
- if (!imp_msv) {
+ if (!imp_msv || !GvCV(imp_msv)) {
if (PL_dirty || is_DESTROY) {
outitems = 0;
goto post_dispatch;
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Tue Feb 7 14:36:52 2012
@@ -92,6 +92,7 @@
t/19fhtrace.t
t/20meta.t
t/30subclass.t
+t/31methcache.t Test caching of inner methods
t/35thrclone.t
t/40profile.t
t/41prof_dump.t
Modified: dbi/trunk/dbixs_rev.h
==============================================================================
--- dbi/trunk/dbixs_rev.h (original)
+++ dbi/trunk/dbixs_rev.h Tue Feb 7 14:36:52 2012
@@ -1,4 +1,3 @@
-/* Fri Feb 3 15:12:19 2012 */
-/* Mixed revision working copy (15106M:15111) */
+/* Tue Feb 7 22:13:18 2012 */
/* Code modified since last checkin */
-#define DBIXS_REVISION 15106
+#define DBIXS_REVISION 15131
Added: dbi/trunk/t/31methcache.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/31methcache.t Tue Feb 7 14:36:52 2012
@@ -0,0 +1,153 @@
+#!perl -w
+#
+# check that the inner-method lookup cache works
+# (or rather, check that it doesn't cache things when it shouldn't)
+
+BEGIN { eval "use threads;" } # Must be first
+my $use_threads_err = $@;
+use Config qw(%Config);
+# With this test code and threads, 5.8.1 has issues with freeing freed
+# scalars, while 5.8.9 doesn't; I don't know about in-between - DAPM
+my $has_threads = $Config{useithreads} && $] >= 5.008009;
+die $use_threads_err if $has_threads && $use_threads_err;
+
+
+use strict;
+
+$|=1;
+$^W=1;
+
+
+
+use Test::More tests => 49;
+
+BEGIN {
+ use_ok( 'DBI' );
+}
+
+sub new_handle {
+ my $dbh = DBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+ });
+
+ my $sth = $dbh->prepare("foo",
+ # data for DBD::Sponge to return via fetch
+ { rows =>
+ [
+ [ "row0" ],
+ [ "row1" ],
+ [ "row2" ],
+ [ "row3" ],
+ [ "row4" ],
+ [ "row5" ],
+ [ "row6" ],
+ ],
+ }
+ );
+
+ return ($dbh, $sth);
+}
+
+
+sub Foo::local1 { [ "local1" ] };
+sub Foo::local2 { [ "local2" ] };
+
+
+my $fetch_hook;
+{
+ package Bar;
+ @Bar::ISA = qw(DBD::_::st);
+ sub fetch { &$fetch_hook };
+}
+
+sub run_tests {
+ my ($desc, $dbh, $sth) = @_;
+ my $row = $sth->fetch;
+ is($row->[0], "row0", "$desc row0");
+
+ {
+ # replace CV slot
+ no warnings 'redefine';
+ local *DBD::Sponge::st::fetch = sub { [ "local0" ] };
+ $row = $sth->fetch;
+ is($row->[0], "local0", "$desc local0");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row1", "$desc row1");
+
+ {
+ # replace GP
+ local *DBD::Sponge::st::fetch = *Foo::local1;
+ $row = $sth->fetch;
+ is($row->[0], "local1", "$desc local1");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row2", "$desc row2");
+
+ {
+ # replace GV
+ local $DBD::Sponge::st::{fetch} = *Foo::local2;
+ $row = $sth->fetch;
+ is($row->[0], "local2", "$desc local2");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row3", "$desc row3");
+
+ {
+ # @ISA = NoSuchPackage
+ local $DBD::Sponge::st::{fetch};
+ local @DBD::Sponge::st::ISA = qw(NoSuchPackage);
+ eval { local $SIG{__WARN__} = sub {}; $row = $sth->fetch };
+ like($@, qr/Can't locate DBI object method/, "$desc locate DBI object");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row4", "$desc row4");
+
+ {
+ # @ISA = Bar
+ $fetch_hook = \&DBD::Sponge::st::fetch;
+ local $DBD::Sponge::st::{fetch};
+ local @DBD::Sponge::st::ISA = qw(Bar);
+ $row = $sth->fetch;
+ is($row->[0], "row5", "$desc row5");
+ $fetch_hook = sub { [ "local3" ] };
+ $row = $sth->fetch;
+ is($row->[0], "local3", "$desc local3");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row6", "$desc row6");
+}
+
+run_tests("plain", new_handle());
+
+
+SKIP: {
+ skip "no threads / perl < 5.8.9", 12 unless $has_threads;
+ # only enable this when handles are allowed to be shared across threads
+ #{
+ # my @h = new_handle();
+ # threads->new(sub { run_tests("threads", @h) })->join;
+ #}
+ threads->new(sub { run_tests("threads-h", new_handle()) })->join;
+};
+
+# using weaken attaches magic to the CV; see whether this interferes
+# with the cache magic
+
+use Scalar::Util qw(weaken);
+my $fetch_ref = \&DBI::st::fetch;
+weaken $fetch_ref;
+run_tests("magic", new_handle());
+
+SKIP: {
+ skip "no threads / perl < 5.8.9", 12 unless $has_threads;
+ # only enable this when handles are allowed to be shared across threads
+ #{
+ # my @h = new_handle();
+ # threads->new(sub { run_tests("threads", @h) })->join;
+ #}
+ threads->new(sub { run_tests("magic threads-h", new_handle()) })->join;
+};
+
+1;
