The 8 attached patches (to be applied in sequence) all provide tweaks,
cleanup, or otherwise attempt to make DBI_dispatch go a little bit faster.
This speedups are all relatively minor, and my timings show the
cumulative speedup for my standard fetch() test loop is somewhere between
0% and 9% based on the perl version (better for newer perls), but
generally with a variation of around 5% between test runs. So take with a
pinch of salt.
These patches should be possible to apply without my DBIS patch having
been applied (although some hand merging might be necessary).
The first patch is the biggest. It moves the method lookup cache into the
dbi_ima_t struct (rather than being directly attached to magic).
This is what you originally suggested I do, but I couldn't do it because
the any_ptr field in the CV wouldn't be properly duped or freed.
I subsequently realised that I could get round this by attaching magic
(with dup and free functions), which administers to the any_ptr field.
This makes things a lot simpler.
It was then made more complex again by the fact that in perls < 5.8.9, the
new any_ptr field is overwritten after the magic dup handler is called :-(
So there's some special ifdef'd code to handle this.
This patch also means that *all* CVs are given dbi_ima_t structure when
installed, rather than only the ones with attributes.
The second patch just inlines the method cache lookup, now that it's
simpler.
The third makes use of ima always being available, by pre-calculating
type of method at install time; i.e. this
*meth_name =='F' && strEQ(meth_name,"FETCH")
becomes
meth_type == methtype_FETCH
The fourth does a shortcut for mg_find, similar to that done in
dbih_getcom2().
The fifth follows on from that by eliminating the is_FETCH var.
The sixth slightly tweaks where qsv (quick SV) is tested.
The seventh removes some GV tests relating to the method to be called.
It used to do isGV(imp_msv) before accessing GvCV(imp_msv); but since an
earlier bit of code accesses GvCV(imp_msv) before the test, I assume
that either the test is redundant and imp_msv is always a gv, or
that it might not be a GV and it's just a miracle that the code hasn't
SEGVed in the past (if the latter, then my patch is wrong).
The eighth optimises the stack handling done before/after the inner method
call in the XS case.
Dave
--
print+qq&$}$"$/$s$,$a$d$g$s$@$.$q$,$:$.$q$^$,$@$a$~$;$.$q$m&if+map{m,^\d{0\,},,${$::{$'}}=chr($"+=$&||1)}q&10m22,42}6:17a2~2.3@3;^2dg3q/s"&=~m*\d\*.*g
>From 7b75e81af1d8563dce002f23ead618150749e592 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Mon, 20 Feb 2012 18:38:13 +0000
Subject: [PATCH 1/8] move method cache into dbi_ima_t struct
The recently-added method cache stored the cache in magic attached to the
outer CV, rather than in the dbi_ima_t structure also attached to the CV,
because the dbi_ima_t structure couldn't be duped or freed, and so
couldn't have reference-counted SVs stored in it.
Change it so that the cache is now stored in the dbi_ima_t struct; but
still attach magic, who's sole function is to provide dup() and free()
methods which administer the dbi_ima_t struct.
This makes the code simpler, and also means that at method lookup time,
we don't have to retrieve any structures from magic.
Note that with this change, every DBI_dispatch method has a dbi_ima_t
struct, not just those with attributes. This will allow us to make further
use of it in the future.
There's a wart however. In thread cloning in perls before 5.8.9,
the any_ptr is copied from the old to the new CV *after* our magic dup
function is called, thus stopping us from being able to duplicate the
dbi_ima_t structure. We work round this (in code clearly delineated with
the BROKEN_DUP_ANY_PTR macro) by instead storing the current perl
interpreter address in in the dbi_ima_t; then in XS_DBI_dispatch,
we duplcate the dbi_ima_t at that point if the my_perl's don't match.
Clumsy, but should still be more efficient than the previous method of
storing the cache.
Once support for 5.8.x is dropped, it will be easy to remove this extra
code.
---
DBI.xs | 184 ++++++++++++++++++++++++++++++++++++----------------------------
1 files changed, 103 insertions(+), 81 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index 27b93b4..217e314 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -80,6 +80,14 @@ extern Pid_t getpid (void);
#define DBI_save_hv_fetch_ent
#endif
+/* prior to 5.8.9: when a CV is duped, the mg dup method is called,
+ * then *afterwards*, any_ptr is copied from the old CV to the new CV.
+ * This wipes out anything which the dup method did to any_ptr.
+ * This needs working around */
+#if defined(USE_ITHREADS) && (PERL_VERSION == 8) && (PERL_SUBVERSION < 9)
+# define BROKEN_DUP_ANY_PTR
+#endif
+
static imp_xxh_t *dbih_getcom _((SV *h));
static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp));
@@ -100,8 +108,10 @@ static int sql_type_cast_svpv _((pTHX_ SV *sv, int
sql_type, U32 flags, voi
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 int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg);
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param);
+#endif
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);
@@ -113,7 +123,8 @@ struct imp_fdh_st { dbih_fdc_t com; };
/* Internal Method Attributes (attached to dispatch methods when installed) */
-/* NOTE: don't include SVs in dbi_ima_t as they won't be cloned by threads */
+/* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free()
+ * to ensure that they are duped and correctly ref-counted */
typedef struct dbi_ima_st {
U8 minargs;
@@ -128,6 +139,15 @@ typedef struct dbi_ima_st {
U32 method_trace;
const char *usage_msg;
U32 flags;
+
+ /* cached outer to inner method mapping */
+ HV *stash; /* the stash we found the GV in */
+ GV *gv; /* the GV containing the inner sub */
+ U32 generation; /* cache invalidation */
+#ifdef BROKEN_DUP_ANY_PTR
+ PerlInterpreter *my_perl; /* who owns this struct */
+#endif
+
} dbi_ima_t;
/* These values are embedded in the data passed to install_method */
@@ -182,103 +202,80 @@ static char *dbi_build_opt = "-nothread";
#define FNV_32_PRIME ((UV)0x01000193)
-
-/* ext magic attached to outer CV methods to quickly locate the
- * corresponding inner method
+/* perl doesn't know anything about the dbi_ima_t struct attached to the
+ * CvXSUBANY(cv).any_ptr slot, so add some magic to the CV to handle
+ * duping and freeing.
*/
-static MGVTBL method_cache_vtbl = { 0, 0, 0, 0, method_cache_free,
- 0, method_cache_dup
+static MGVTBL dbi_ima_vtbl = { 0, 0, 0, 0, dbi_ima_free,
+ 0,
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+ dbi_ima_dup
+#else
+ 0
+#endif
#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)
+static int dbi_ima_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);
+ dbi_ima_t *ima = (dbi_ima_t *)(CvXSUBANY((CV*)sv).any_ptr);
+#ifdef BROKEN_DUP_ANY_PTR
+ if (ima->my_perl != my_perl)
+ return 0;
+#endif
+ SvREFCNT_dec(ima->stash);
+ SvREFCNT_dec(ima->gv);
+ Safefree(ima);
return 0;
}
-static int method_cache_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param)
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+static int dbi_ima_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;
+ dbi_ima_t *ima, *nima;
+ CV *cv = (CV*) mg->mg_ptr;
+ CV *ncv = (CV*)ptr_table_fetch(PL_ptr_table, (cv));
+
+ (void)param; /* avoid 'unused variable' warning */
+ ima = (dbi_ima_t*) CvXSUBANY(cv).any_ptr;
+ Newx(nima, 1, dbi_ima_t);
+ *nima = *ima; /* structure copy */
+ CvXSUBANY(ncv).any_ptr = nima;
+ nima->stash = NULL;
+ nima->gv = NULL;
return 0;
}
+#endif
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;
- }
- }
+ dbi_ima_t *ima = (dbi_ima_t*)(CvXSUBANY(cv).any_ptr);
- if ( (c=(method_cache_t *)(mg->mg_ptr))
- && c->stash == stash
- && c->generation == PL_sub_generation + MY_cache_gen(stash)
- )
- return c->gv;
+ if ( ima->stash == stash
+ && ima->generation == PL_sub_generation + MY_cache_gen(stash)
+ )
+ return ima->gv;
- /* clear stale cache */
- SvREFCNT_dec(c->stash);
- SvREFCNT_dec(c->gv);
- c->stash = NULL;
- c->gv = NULL;
- }
+ /* clear stale entry, if any */
+ SvREFCNT_dec(ima->stash);
+ SvREFCNT_dec(ima->gv);
- no_match:
gv = gv_fetchmethod_autoload(stash, meth_name, FALSE);
- if (!gv)
+ if (!gv) {
+ ima->stash = NULL;
+ ima->gv = NULL;
return NULL;
-
- /* create new cache entry */
- if (!mg) {
- c = 0; /* silence "may be used uninitialized in this function" */
- 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 + MY_cache_gen(stash);
+ ima->stash = stash;
+ ima->gv = gv;
+ ima->generation = PL_sub_generation + MY_cache_gen(stash);
return gv;
}
@@ -3111,12 +3108,27 @@ XS(XS_DBI_dispatch)
const char *meth_name = GvNAME(CvGV(cv));
const dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
- const U32 ima_flags = (ima) ? ima->flags : 0;
+ U32 ima_flags;
imp_xxh_t *imp_xxh = NULL;
SV *imp_msv = Nullsv;
SV *qsv = Nullsv; /* quick result from a shortcut method
*/
+#ifdef BROKEN_DUP_ANY_PTR
+ if (ima->my_perl != my_perl) {
+ /* we couldn't dup the ima struct at clone time, so do it now */
+ dbi_ima_t *nima;
+ Newx(nima, 1, dbi_ima_t);
+ *nima = *ima; /* structure copy */
+ CvXSUBANY(cv).any_ptr = nima;
+ nima->stash = NULL;
+ nima->gv = NULL;
+ nima->my_perl = my_perl;
+ ima = nima;
+ }
+#endif
+
+ ima_flags = ima->flags;
if (trace_level >= 9) {
PerlIO *logfp = DBILOGFP;
PerlIO_printf(logfp,"%c >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x
ima%lx pid#%ld)",
@@ -3248,7 +3260,7 @@ XS(XS_DBI_dispatch)
#endif
/* Check method call against Internal Method Attributes */
- if (ima) {
+ if (ima_flags) {
if (ima_flags &
(IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) {
@@ -4524,8 +4536,9 @@ _install_method(dbi_class, meth_name, file,
attribs=Nullsv)
SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) :
Nullsv;
CV *cv;
SV **svp;
- dbi_ima_t *ima = NULL;
+ dbi_ima_t *ima;
(void)dbi_class;
+ MAGIC *mg;
if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */
croak("install_method %s: invalid class", meth_name);
@@ -4533,15 +4546,13 @@ _install_method(dbi_class, meth_name, file,
attribs=Nullsv)
if (trace_msg)
sv_catpvf(trace_msg, "install_method %-21s", meth_name);
+ Newxz(ima, 1, dbi_ima_t);
+
if (attribs && SvOK(attribs)) {
/* convert and store method attributes in a fast access form */
- SV *sv;
if (SvTYPE(SvRV(attribs)) != SVt_PVHV)
croak("install_method %s: bad attribs", meth_name);
- sv = newSV(sizeof(*ima));
- ima = (dbi_ima_t*)(void*)SvPVX(sv);
- memzero((char*)ima, sizeof(*ima));
DBD_ATTRIB_GET_IV(attribs, "O",1, svp, ima->flags);
DBD_ATTRIB_GET_UV(attribs, "T",1, svp, ima->method_trace);
DBD_ATTRIB_GET_IV(attribs, "H",1, svp, ima->hidearg);
@@ -4567,6 +4578,17 @@ _install_method(dbi_class, meth_name, file,
attribs=Nullsv)
PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg));
cv = newXS(meth_name, XS_DBI_dispatch, file);
CvXSUBANY(cv).any_ptr = ima;
+ /* Attach magic to handle duping and freeing of the dbi_ima_t struct.
+ * Due to the poor interface of the mg dup function, sneak a pointer
+ * to the original CV in the mg_ptr field (we get called with a
+ * pointer to the mg, but not the SV) */
+ mg = sv_magicext((SV*)cv, NULL, DBI_MAGIC, &dbi_ima_vtbl,
+ (char *)cv, 0);
+#ifdef BROKEN_DUP_ANY_PTR
+ ima->my_perl = my_perl; /* who owns this struct */
+#else
+ mg->mg_flags |= MGf_DUP;
+#endif
ST(0) = &PL_sv_yes;
}
--
1.7.4.4
>From 7dcae3ee6375ec86fdce0bd70e5e285a4159287e Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Wed, 22 Feb 2012 20:45:49 +0000
Subject: [PATCH 2/8] inline inner_method_lookup()
---
DBI.xs | 59 ++++++++++++++++++++++++-----------------------------------
1 files changed, 24 insertions(+), 35 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index 217e314..ec0b2bd 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -112,7 +112,6 @@ static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg);
#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param);
#endif
-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);
@@ -250,35 +249,6 @@ static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS
*param)
}
#endif
-static GV* inner_method_lookup(pTHX_ HV *stash, CV *cv, const char *meth_name)
-{
- GV *gv;
- dbi_ima_t *ima = (dbi_ima_t*)(CvXSUBANY(cv).any_ptr);
-
- if ( ima->stash == stash
- && ima->generation == PL_sub_generation + MY_cache_gen(stash)
- )
- return ima->gv;
-
- /* clear stale entry, if any */
- SvREFCNT_dec(ima->stash);
- SvREFCNT_dec(ima->gv);
-
- gv = gv_fetchmethod_autoload(stash, meth_name, FALSE);
- if (!gv) {
- ima->stash = NULL;
- ima->gv = NULL;
- return NULL;
- }
-
- SvREFCNT_inc(stash);
- SvREFCNT_inc(gv);
- ima->stash = stash;
- ima->gv = gv;
- ima->generation = PL_sub_generation + MY_cache_gen(stash);
- return gv;
-}
-
/* --- make DBI safe for multiple perl interpreters --- */
@@ -3107,7 +3077,7 @@ XS(XS_DBI_dispatch)
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;
+ dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
U32 ima_flags;
imp_xxh_t *imp_xxh = NULL;
SV *imp_msv = Nullsv;
@@ -3535,12 +3505,31 @@ XS(XS_DBI_dispatch)
}
}
- if (is_orig_method_name)
- imp_msv = (SV*)inner_method_lookup(aTHX_ DBIc_IMP_STASH(imp_xxh),
- cv, meth_name);
- else
+ if (is_orig_method_name
+ && ima->stash == DBIc_IMP_STASH(imp_xxh)
+ && ima->generation == PL_sub_generation +
+ MY_cache_gen(DBIc_IMP_STASH(imp_xxh))
+ )
+ imp_msv = (SV*)ima->gv;
+ else {
imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
meth_name, FALSE);
+ if (is_orig_method_name) {
+ /* clear stale entry, if any */
+ SvREFCNT_dec(ima->stash);
+ SvREFCNT_dec(ima->gv);
+ if (!imp_msv) {
+ ima->stash = NULL;
+ ima->gv = NULL;
+ }
+ else {
+ ima->stash = (HV*)SvREFCNT_inc(DBIc_IMP_STASH(imp_xxh));
+ ima->gv = (GV*)SvREFCNT_inc(imp_msv);
+ ima->generation = PL_sub_generation +
+ MY_cache_gen(DBIc_IMP_STASH(imp_xxh));
+ }
+ }
+ }
/* if method was a 'func' then try falling back to real 'func' method
*/
if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) {
--
1.7.4.4
>From 8a329d0c8de63c67e1797f647c351494df968937 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Wed, 22 Feb 2012 22:33:19 +0000
Subject: [PATCH 3/8] detmeine method type when installed
rather than doing repeated stuff like
*meth_name=='F' && strEQ(meth_name,"FETCH")
on each dispatch, just work out what typer of method it is once at install
time, and store the result as an enum in dbi_ima.
---
DBI.xs | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------
1 files changed, 58 insertions(+), 8 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index ec0b2bd..f987f6c 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -88,6 +88,17 @@ extern Pid_t getpid (void);
# define BROKEN_DUP_ANY_PTR
#endif
+/* types of method name */
+
+typedef enum {
+ methtype_ordinary, /* nothing special about this method name */
+ methtype_DESTROY,
+ methtype_FETCH,
+ methtype_can,
+ methtype_fetch_star, /* fetch*, i.e. fetch() or fetch_...() */
+ methtype_set_err
+} meth_types;
+
static imp_xxh_t *dbih_getcom _((SV *h));
static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp));
@@ -114,12 +125,43 @@ static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS
*param);
#endif
char *neatsvpv _((SV *sv, STRLEN maxlen));
SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void
*foo);
+static meth_types get_meth_type(const char * const name);
struct imp_drh_st { dbih_drc_t com; };
struct imp_dbh_st { dbih_dbc_t com; };
struct imp_sth_st { dbih_stc_t com; };
struct imp_fdh_st { dbih_fdc_t com; };
+/* identify the type of a method name */
+
+static meth_types
+get_meth_type(const char * const name)
+{
+ switch (name[0]) {
+ case 'D':
+ if strEQ(name,"DESTROY")
+ return methtype_DESTROY;
+ break;
+ case 'F':
+ if strEQ(name,"FETCH")
+ return methtype_FETCH;
+ break;
+ case 'c':
+ if strEQ(name,"can")
+ return methtype_can;
+ break;
+ case 'f':
+ if strnEQ(name,"fetch", 5) /* fetch* */
+ return methtype_fetch_star;
+ break;
+ case 's':
+ if strEQ(name,"set_err")
+ return methtype_set_err;
+ break;
+ }
+ return methtype_ordinary;
+}
+
/* Internal Method Attributes (attached to dispatch methods when installed) */
/* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free()
@@ -138,6 +180,7 @@ typedef struct dbi_ima_st {
U32 method_trace;
const char *usage_msg;
U32 flags;
+ meth_types meth_type;
/* cached outer to inner method mapping */
HV *stash; /* the stash we found the GV in */
@@ -3067,6 +3110,7 @@ XS(XS_DBI_dispatch)
I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK);
int is_DESTROY;
int is_FETCH;
+ meth_types meth_type;
int is_unrelated_to_Statement = 0;
int keep_error = FALSE;
UV ErrCount = UV_MAX;
@@ -3099,6 +3143,7 @@ XS(XS_DBI_dispatch)
#endif
ima_flags = ima->flags;
+ meth_type = ima->meth_type;
if (trace_level >= 9) {
PerlIO *logfp = DBILOGFP;
PerlIO_printf(logfp,"%c >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x
ima%lx pid#%ld)",
@@ -3109,7 +3154,7 @@ XS(XS_DBI_dispatch)
PerlIO_flush(logfp);
}
- if ( ( (is_DESTROY=(*meth_name=='D' && strEQ(meth_name,"DESTROY")))) ) {
+ if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) {
/* note that croak()'s won't propagate, only append to $@ */
keep_error = TRUE;
}
@@ -3171,7 +3216,7 @@ XS(XS_DBI_dispatch)
imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle
Attributes */
if (!imp_xxh) {
- if (strEQ(meth_name, "can")) { /* ref($h)->can("foo") */
+ if (meth_type == methtype_can) { /* ref($h)->can("foo") */
const char *can_meth = SvPV_nolen(st1);
SV *rv = &PL_sv_undef;
GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE),
can_meth, FALSE);
@@ -3235,7 +3280,7 @@ XS(XS_DBI_dispatch)
if (ima_flags &
(IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) {
if (ima_flags & IMA_STUB) {
- if (*meth_name == 'c' && strEQ(meth_name,"can")) {
+ if (meth_type == methtype_can) {
const char *can_meth = SvPV_nolen(st1);
SV *dbi_msv = Nullsv;
/* find handle implementors method (GV or CV) */
@@ -3265,6 +3310,7 @@ XS(XS_DBI_dispatch)
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);
+ meth_type = get_meth_type(meth_name);
is_orig_method_name = 0;
}
if (ima_flags & IMA_KEEP_ERR)
@@ -3362,7 +3408,7 @@ XS(XS_DBI_dispatch)
/* --- dispatch --- */
- if (!keep_error && !(*meth_name=='s' && strEQ(meth_name,"set_err"))) {
+ if (!keep_error && meth_type != methtype_set_err) {
SV *err_sv;
if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) {
PerlIO *logfp = DBILOGFP;
@@ -3385,7 +3431,8 @@ XS(XS_DBI_dispatch)
* Other restrictions may be added over time.
* It's an undocumented hack.
*/
- || (!is_nested_call && !PL_dirty && strNE(meth_name, "set_err") &&
strNE(meth_name, "DESTROY") &&
+ || (!is_nested_call && !PL_dirty && meth_type != methtype_set_err &&
+ meth_type != methtype_DESTROY &&
(hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0))
)
)
@@ -3460,7 +3507,7 @@ XS(XS_DBI_dispatch)
/* The "quick_FETCH" logic... */
/* Shortcut for fetching attributes to bypass method call overheads */
- if ( (is_FETCH = (*meth_name=='F' && strEQ(meth_name,"FETCH"))) &&
!DBIc_COMPAT(imp_xxh)) {
+ if ( (is_FETCH = (meth_type == methtype_FETCH)) && !DBIc_COMPAT(imp_xxh)) {
STRLEN kl;
const char *key = SvPV(st1, kl);
SV **attr_svp;
@@ -3540,6 +3587,7 @@ XS(XS_DBI_dispatch)
PUTBACK;
++items;
meth_name = "func";
+ meth_type = methtype_ordinary;
}
}
@@ -3655,7 +3703,7 @@ XS(XS_DBI_dispatch)
if (trace_level >= (is_nested_call ? 3 : 1)) {
PerlIO *logfp = DBILOGFP;
- const int is_fetch = (*meth_name=='f' && DBIc_TYPE(imp_xxh)==DBIt_ST
&& strnEQ(meth_name,"fetch",5));
+ const int is_fetch = (meth_type == methtype_fetch_star &&
DBIc_TYPE(imp_xxh)==DBIt_ST);
const int row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh)
: 0;
if (is_fetch && row_count>=2 && trace_level<=4 && SvOK(ST(0))) {
/* skip the 'middle' rows to reduce output */
@@ -3819,7 +3867,7 @@ XS(XS_DBI_dispatch)
const char *err_meth_name = meth_name;
char intro[200];
- if (*meth_name=='s' && strEQ(meth_name,"set_err")) {
+ if (meth_type == methtype_set_err) {
SV **sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18,
GV_ADDWARN);
if (SvOK(*sem_svp))
err_meth_name = SvPV_nolen(*sem_svp);
@@ -4567,6 +4615,8 @@ _install_method(dbi_class, meth_name, file,
attribs=Nullsv)
PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg));
cv = newXS(meth_name, XS_DBI_dispatch, file);
CvXSUBANY(cv).any_ptr = ima;
+ ima->meth_type = get_meth_type(GvNAME(CvGV(cv)));
+
/* Attach magic to handle duping and freeing of the dbi_ima_t struct.
* Due to the poor interface of the mg dup function, sneak a pointer
* to the original CV in the mg_ptr field (we get called with a
--
1.7.4.4
>From 700db83559187d0eadcb730d0a941cc8aabe7848 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Thu, 23 Feb 2012 14:34:34 +0000
Subject: [PATCH 4/8] in XS_DBI_dispatch, short-cut mg_find
On the assumption that the tie magic we're after is likely to be the
first one, check for it first, and only call mg_find() for the general
case.
---
DBI.xs | 9 +++++++--
1 files changed, 7 insertions(+), 2 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index f987f6c..8fe016a 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3165,8 +3165,13 @@ XS(XS_DBI_dispatch)
data (without having to go through FETCH and STORE methods) and
for tie and non-tie methods to call each other.
*/
- if (SvROK(h) && SvRMAGICAL(SvRV(h)) && (mg=mg_find(SvRV(h),'P'))!=NULL) {
-
+ if (SvROK(h)
+ && SvRMAGICAL(SvRV(h))
+ && (
+ ((mg=SvMAGIC(SvRV(h)))->mg_type == 'P')
+ || ((mg=mg_find(SvRV(h),'P')) != NULL)
+ )
+ ) {
if (mg->mg_obj==NULL || !SvOK(mg->mg_obj) || SvRV(mg->mg_obj)==NULL) {
/* maybe global destruction */
if (trace_level >= 3)
PerlIO_printf(DBILOGFP,
--
1.7.4.4
>From e5976f54858d7a31cc2026912f2ba3dd40ca55cf Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Thu, 23 Feb 2012 14:49:09 +0000
Subject: [PATCH 5/8] XS_DBI_dispatch: eliminate is_FETCH
Since its now easy to test for a particular method name, its not worth
saving it in a boolean just to be used 2-3 times.
---
DBI.xs | 7 +++----
1 files changed, 3 insertions(+), 4 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index 8fe016a..68262dd 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3109,7 +3109,6 @@ XS(XS_DBI_dispatch)
I32 trace_flags = DBIS->debug; /* local copy may change during
dispatch */
I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK);
int is_DESTROY;
- int is_FETCH;
meth_types meth_type;
int is_unrelated_to_Statement = 0;
int keep_error = FALSE;
@@ -3512,7 +3511,7 @@ XS(XS_DBI_dispatch)
/* The "quick_FETCH" logic... */
/* Shortcut for fetching attributes to bypass method call overheads */
- if ( (is_FETCH = (meth_type == methtype_FETCH)) && !DBIc_COMPAT(imp_xxh)) {
+ if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) {
STRLEN kl;
const char *key = SvPV(st1, kl);
SV **attr_svp;
@@ -3540,7 +3539,7 @@ XS(XS_DBI_dispatch)
else {
#ifdef DBI_save_hv_fetch_ent
HE save_mh;
- if (is_FETCH)
+ if (meth_type == methtype_FETCH)
save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575
workaround */
#endif
@@ -3682,7 +3681,7 @@ XS(XS_DBI_dispatch)
ax = (SP - PL_stack_base) + 1;
#ifdef DBI_save_hv_fetch_ent
- if (is_FETCH)
+ if (meth_type == methtype_FETCH)
PL_hv_fetch_ent_mh = save_mh; /* see start of block */
#endif
}
--
1.7.4.4
>From 11a9fa057a1b9c67818c783c275abddd313235e7 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Thu, 23 Feb 2012 16:03:06 +0000
Subject: [PATCH 6/8] XS_DBI_dispatch: only test qsv when it may be set
Only test qsv in the branch where it might be set.
Yes, this is a micro-optimisation.
---
DBI.xs | 13 ++++++-------
1 files changed, 6 insertions(+), 7 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index 68262dd..de3c8d8 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3528,15 +3528,14 @@ XS(XS_DBI_dispatch)
if (*key == 'P' && strEQ(key, "Profile"))
profile_t1 = 0.0;
}
+ if (qsv) { /* skip real method call if we already have a 'quick' value
*/
+ ST(0) = sv_mortalcopy(qsv);
+ outitems = 1;
+ goto post_dispatch;
+ }
}
- if (qsv) { /* skip real method call if we already have a 'quick' value */
-
- ST(0) = sv_mortalcopy(qsv);
- outitems = 1;
-
- }
- else {
+ {
#ifdef DBI_save_hv_fetch_ent
HE save_mh;
if (meth_type == methtype_FETCH)
--
1.7.4.4
>From bcad4ee677b14a650f02b6ac791b3f686291eac4 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Thu, 23 Feb 2012 16:29:40 +0000
Subject: [PATCH 7/8] XS_DBI_dispatch: micro-optimise method cv
assign GvCV(imp_msv) to a variable, as it is accessed several times;
also skip the isGV(imp_msv) tests, as we've already tested GvCV(imp_msv),
which can't be valid unless imp_msv is always a GV.
---
DBI.xs | 11 +++++------
1 files changed, 5 insertions(+), 6 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index de3c8d8..81b095b 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3536,6 +3536,7 @@ XS(XS_DBI_dispatch)
}
{
+ CV *meth_cv;
#ifdef DBI_save_hv_fetch_ent
HE save_mh;
if (meth_type == methtype_FETCH)
@@ -3622,7 +3623,7 @@ XS(XS_DBI_dispatch)
PerlIO_flush(logfp);
}
- if (!imp_msv || !GvCV(imp_msv)) {
+ if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) {
if (PL_dirty || is_DESTROY) {
outitems = 0;
goto post_dispatch;
@@ -3643,16 +3644,14 @@ XS(XS_DBI_dispatch)
*/
/* SHORT-CUT ALERT! */
- if (use_xsbypass && isGV(imp_msv) && CvISXSUB(GvCV(imp_msv))
- && CvXSUB(GvCV(imp_msv))) {
+ if (use_xsbypass && CvISXSUB(meth_cv) && CvXSUB(meth_cv)) {
/* If we are calling an XSUB we jump directly to its C code and
* bypass perl_call_sv(), pp_entersub() etc. This is fast.
* This code is copied from a small section of pp_entersub().
*/
I32 markix = TOPMARK;
- CV *xscv = GvCV(imp_msv);
- (void)(*CvXSUB(xscv))(aTHXo_ xscv); /* Call the C code directly */
+ (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code
directly */
if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */
if (++markix != PL_stack_sp - PL_stack_base ) {
@@ -3670,7 +3669,7 @@ XS(XS_DBI_dispatch)
}
else {
/* sv_dump(imp_msv); */
- outitems = call_sv(isGV(imp_msv) ? (SV*)GvCV(imp_msv) : imp_msv,
+ outitems = call_sv((SV*)meth_cv,
(is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) );
}
SPAGAIN;
--
1.7.4.4
>From 145a0dd9437f1bf7d725ddaac46f1190b59f2de8 Mon Sep 17 00:00:00 2001
From: David Mitchell <da...@iabyn.com>
Date: Fri, 24 Feb 2012 13:56:45 +0000
Subject: [PATCH 8/8] XS_DBI_dispatch: optimise stack handling
Simplify the code the fixes up the stack and associated vars after a
method call. Note that ax is an offset from stack base rather than a
pointer, so it doesn't need to be restored afterwards. Also,
markix+1 == ax, so we can dispense with markix.
---
DBI.xs | 21 +++++++++------------
1 files changed, 9 insertions(+), 12 deletions(-)
diff --git a/DBI.xs b/DBI.xs
index 81b095b..4061cff 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3648,22 +3648,22 @@ XS(XS_DBI_dispatch)
/* If we are calling an XSUB we jump directly to its C code and
* bypass perl_call_sv(), pp_entersub() etc. This is fast.
- * This code is copied from a small section of pp_entersub().
+ * This code is based on a small section of pp_entersub().
*/
- I32 markix = TOPMARK;
(void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code
directly */
if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */
- if (++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
+ if (ax != PL_stack_sp - PL_stack_base ) { /* outitems != 1 */
+ ST(0) =
+ (ax > PL_stack_sp - PL_stack_base)
+ ? &PL_sv_undef /* outitems == 0 */
+ : *PL_stack_sp; /* outitems > 1 */
+ PL_stack_sp = PL_stack_base + ax;
}
outitems = 1;
}
else {
- outitems = PL_stack_sp - (PL_stack_base + markix);
+ outitems = PL_stack_sp - (PL_stack_base + ax - 1);
}
}
@@ -3672,11 +3672,8 @@ XS(XS_DBI_dispatch)
outitems = call_sv((SV*)meth_cv,
(is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) );
}
- SPAGAIN;
- /* XXX restore local vars so ST(n) works below */
- SP -= outitems;
- ax = (SP - PL_stack_base) + 1;
+ XSprePUSH; /* reset SP to base of stack frame */
#ifdef DBI_save_hv_fetch_ent
if (meth_type == methtype_FETCH)
--
1.7.4.4
