On Mon, Jan 30, 2012 at 10:56:37PM +0000, Tim Bunce wrote:
> On Mon, Jan 30, 2012 at 12:48:32PM +0000, Dave Mitchell wrote:
> > So I'm tempted to stick with the magic approach. I could optimise
> > it to assume the cache magic is always the first one (and if not, take a
> > slower route that finds and then moves it to the top).
>
> That would be neat. Thanks.
>
> dbih_getcom2 does the first part of that when looking up DBI hande
> magic. I never added the "move to the top" because I figured it would be
> very rare for magic to get added to the inner hash of a DBI handle.
> It seems even less likely that someone would add magic to a DBI method,
> but you never know. Unless you can think of a plausible case I'd be
> happy if you just added the short-cut+fallback and skipped the shuffle.
I'd already written the magic shuffler code by the time I saw your email,
so unless you want me to rip it out, it's your's fro free!
Anyway, attached is the final patch.
I've tested it under 5.8.1, 5.8.9, 5.14.2 and 5.15.7, with various
permutations of threaded builds.
It took quite a bit more work from the initial draft I showed you, mainly
getting the threaded stuff right, and a stupid PL_generation /
PL_sub_generation mix-up. I knew what the difference was between the two
vars, but whenever I visually inspected the code, I kept seeing the former
as the latter and couldn't understand why cache invalidation didn't work!
--
Little fly, thy summer's play my thoughtless hand
has terminated with extreme prejudice.
(with apologies to William Blake)
Index: DBI.xs
===================================================================
--- DBI.xs (revision 15130)
+++ DBI.xs (working copy)
@@ -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;
Index: MANIFEST
===================================================================
--- MANIFEST (revision 15130)
+++ MANIFEST (working copy)
@@ -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
Index: t/31methcache.t
===================================================================
--- t/31methcache.t (revision 0)
+++ t/31methcache.t (revision 0)
@@ -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;
