On Thu, Jan 26, 2012 at 12:26:44PM +0000, Tim Bunce wrote:
> On Wed, Jan 25, 2012 at 05:37:13PM -0800, Jan Dubois wrote:
> > On Wed, 25 Jan 2012, Tim Bunce wrote:
> > > On Wed, Jan 25, 2012 at 04:14:07PM +0000, Dave Mitchell wrote:
> > >
> > > > PS - I'm specifically being paid only to fix a performance issue on
> > > > non-threaded builds, so I won't be looking at threaded issues. But
> > > > dPERINTERP looks like bad news on threaded builds.
> > >
> > > The dPERINTERP stuff was added by ActiveState years ago to support
> > > MULTIPLICITY. I don't remember the details now. I do recall that driver
> > > authors are encouraged to avoid using the DBIS macro due to the cost.
> > > There's rarely a need now as DBI handles carry a pointer to the
> > > dbi_state structure. The DBI::DBD docs say
> >
> > Sorry, only skimming the conversation, so maybe this is obvious to
> > you: PERINTERP was a prototype from the 5.005 days for the MY_CXT
> > stuff that is now in the code. If you look at 5.8.1, then you'll see
> > MY_CXT being almost identical to PERINTERP in DBI. But switching to
> > MY_CXT should give you performance benefits on later Perl versions,
> > which have an improved MY_CXT implementation.
>
> Great. Thanks Jan.
>
> Anyone want to take a shot at that?
I attach two patches; the first replaces dPERINTERP with dMY_THX,
while the second extends this to the DBIS stuff too.
The headline figure (YMMV etc) is that on a recent threaded perl, these
two patches collectively make my mysql empty test loop twice as fast!!! :
while ($sth->fetch) { $c++ }
On a perl < 5.10.0 (before dMY_THX was made much more efficient), the
speedup is less spectacular, but is still about 25%.
I'm assuming that these won't be applied until after the windows() fork
issue is fixed, so think of this email more as a preview.
The first fix is relatively straightforward, and is private to DBI.xs,
since the PERINTERP macros were kind of a prototype for MY_CXT anyway.
The second patch, which makes DBIS more efficient, is a lot more complex,
and more likely to break things (especially as it's changing a bunch of
macros that are directly #included by the DBD drivers. You may need to
bump API version numbers; I don't understand that bit.
It works by adding a C function, _dbi_state_lval(), to DBI.xs which
returns a pointer to the static(ish) dbistate struct that only DBI.xs
knows about. However, I couldn't find any way for DBD:: code to call
functions within DBI, so I did a little hack: I faked up an XS sub,
&DBI::_dbi_state_lval(), whose CvXSUB points to the _dbi_state_lval
function. Since _dbi_state_lval() isn't actually an XS function,
perl-level code that tries to call &DBI::_dbi_state_lval() will crash and
burn.
If anyone knows of a more elegant way to make a function from DBI.xs
available to DBD:: code, please let me know!
Anyway, at the DBD end of things, the code extracts the address of the
function from &DBI::_dbi_state_lval's CvXSUB slot, and caches it in
a static var. Then in threaded builds, DBIS expands to a call to a static
function that calls _dbi_state_lval() which returns &(MY_CXT.dbi_state).
In unthreaded builds, it just returns the value of a static var as normal.
Here are some timings; remember that MY_CXT was made a lot faster in
5.10.0, so I've included timings for 5.8.9 too. As you'd expect, only the
threaded build have a significant speed-up; I think the tiny speed-ups in
the non-threaded builds are just noise.
The three timings (in sec) for the basic while($sth->fetch){$c++} loop
are for:
(1) the baseline: r15128 plus my method cache code
(2) in addition, replace dPERINTERP with dMY_CXT
(3) in addition, fix DBIS
1 2 3
----- ------ ------
40.10 - 29.96 5.8.9 threaded, optimised
37.62 33.98 18.96 5.15.7 threaded, optimised
12.85 - 12.55 5.8.9 unthreaded, optimised
13.41 13.46 12.97 5.15.6 unthreaded, optimised
The big saving between (2) and (3) is due to DBD::mysql still using DBIS;
in particular, for every fetch call.
--
This email is confidential, and now that you have read it you are legally
obliged to shoot yourself. Or shoot a lawyer, if you prefer. If you have
received this email in error, place it in its original wrapping and return
for a full refund. By opening this email, you accept that Elvis lives.
diff --git a/DBI.xs b/DBI.xs
index ac161f4..887111d 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -16,8 +16,6 @@
#include <sys/timeb.h>
# endif
-#define MY_VERSION "DBI(" XS_VERSION ")"
-
/* The XS dispatcher code can optimize calls to XS driver methods,
* bypassing the usual call_sv() and argument handling overheads.
* Just-in-case it causes problems there's an (undocumented) way
@@ -277,40 +275,24 @@ static GV* inner_method_lookup(pTHX_ HV *stash, CV *cv,
const char *meth_name)
/* --- make DBI safe for multiple perl interpreters --- */
-/* Contributed by Murray Nesbitt of ActiveState */
-/* (This pre-dates, and should be replaced by, MY_CTX) */
+/* Originally contributed by Murray Nesbitt of ActiveState, */
+/* but later updated to use MY_CTX */
+
+#define MY_CXT_KEY "DBI::_guts" XS_VERSION
+
typedef struct {
SV *dbi_last_h; /* maybe better moved into dbistate_t? */
dbistate_t* dbi_state;
-} PERINTERP_t;
-
-#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
-
-# define dPERINTERP_SV \
- SV *perinterp_sv = *hv_fetch(PL_modglobal, MY_VERSION, \
- sizeof(MY_VERSION)-1, TRUE)
+} my_cxt_t;
-# define dPERINTERP_PTR(T,name) \
- T name = (perinterp_sv && SvIOK(perinterp_sv) \
- ? INT2PTR(T, SvIVX(perinterp_sv)) : (T)NULL)
-# define dPERINTERP \
- dPERINTERP_SV; dPERINTERP_PTR(PERINTERP_t *, PERINTERP)
-# define INIT_PERINTERP \
- dPERINTERP; \
- PERINTERP = malloc_using_sv(sizeof(PERINTERP_t)); \
- sv_setiv(perinterp_sv, PTR2IV(PERINTERP))
+START_MY_CXT
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
# undef DBIS
-# define DBIS (PERINTERP->dbi_state)
-
-#else
- static PERINTERP_t Interp;
-# define dPERINTERP typedef int _interp_DBI_dummy
-# define PERINTERP (&Interp)
-# define INIT_PERINTERP
+# define DBIS (MY_CXT.dbi_state)
#endif
-#define g_dbi_last_h (PERINTERP->dbi_last_h)
+#define g_dbi_last_h (MY_CXT.dbi_last_h)
/* --- */
@@ -492,7 +474,7 @@ check_version(const char *name, int dbis_cv, int dbis_cs,
int need_dbixs_cv, int
int dbc_s, int stc_s, int fdc_s)
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
static const char msg[] = "you probably need to rebuild the DBD driver (or
possibly the DBI)";
(void)need_dbixs_cv;
if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS))
@@ -512,8 +494,8 @@ static void
dbi_bootinit(dbistate_t * parent_dbis)
{
dTHX;
+ dMY_CXT;
dbistate_t* DBISx;
- INIT_PERINTERP;
DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st));
@@ -604,7 +586,7 @@ char *
neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging
only */
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
STRLEN len;
SV *nsv = Nullsv;
SV *infosv = Nullsv;
@@ -903,7 +885,7 @@ dbih_logmsg(imp_xxh_t *imp_xxh, const char *fmt, ...)
static void
close_trace_file(pTHX)
{
- dPERINTERP;
+ dMY_CXT;
if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout())
return;
@@ -920,7 +902,7 @@ static int
set_trace_file(SV *file)
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
const char *filename;
PerlIO *fp = Nullfp;
IO *io;
@@ -1049,7 +1031,7 @@ dbih_inner(pTHX_ SV *orv, const char *what)
if (!what)
return NULL;
if (1) {
- dPERINTERP;
+ dMY_CXT;
if (DBIS_TRACE_LEVEL)
sv_dump(orv);
}
@@ -1110,7 +1092,7 @@ dbih_getcom2(pTHX_ SV *hrv, MAGIC **mgp) /* Get com
struct for handle. Must be f
if (SvROK(hrv)) /* must at least be a ref */
sv = SvRV(hrv);
else {
- dPERINTERP;
+ dMY_CXT;
if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */
sv = DBI_LAST_HANDLE;
else if (sv_derived_from(hrv, "DBI::common")) {
@@ -1246,11 +1228,11 @@ dbih_make_com(SV *p_h, imp_xxh_t *p_imp_xxh, const char
*imp_class, STRLEN imp_s
trace_level = DBIc_TRACE_LEVEL(p_imp_xxh);
}
else {
- dPERINTERP;
+ dMY_CXT;
trace_level = DBIS_TRACE_LEVEL;
}
if (trace_level >= 5) {
- dPERINTERP;
+ dMY_CXT;
PerlIO_printf(DBILOGFP," dbih_make_com(%s, %p, %s, %ld, %p)
thr#%p\n",
neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size,
(void*)imp_templ, (void*)PERL_GET_THX);
}
@@ -1298,7 +1280,7 @@ dbih_make_com(SV *p_h, imp_xxh_t *p_imp_xxh, const char
*imp_class, STRLEN imp_s
DBIc_DBISTATE(imp) = DBIc_DBISTATE(p_imp_xxh);
}
else {
- dPERINTERP;
+ dMY_CXT;
DBIc_DBISTATE(imp) = DBIS;
}
DBIc_IMP_STASH(imp) = imp_stash;
@@ -1362,13 +1344,13 @@ dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV
*parent, SV *imp_datasv)
trace_level = DBIc_TRACE_LEVEL(parent_imp);
}
else {
- dPERINTERP;
+ dMY_CXT;
parent_imp = NULL;
trace_level = DBIS_TRACE_LEVEL;
}
if (trace_level >= 5) {
- dPERINTERP;
+ dMY_CXT;
PerlIO_printf(DBILOGFP," dbih_setup_handle(%s=>%s, %s, %lx, %s)\n",
neatsvpv(orv,0), neatsvpv(h,0), imp_class, (long)parent,
neatsvpv(imp_datasv,0));
}
@@ -1486,7 +1468,7 @@ dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV
*parent, SV *imp_datasv)
SvRMAGICAL_on(SvRV(h)); /* so DBI magic gets sv_clear'd ok */
{
- dPERINTERP; /* XXX would be nice to get rid of this */
+ dMY_CXT; /* XXX would be nice to get rid of this */
DBI_SET_LAST_HANDLE(h);
}
@@ -1524,7 +1506,7 @@ 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)
{
- dPERINTERP;
+ dMY_CXT;
SV *flags = sv_2mortal(newSVpv("",0));
SV *inner;
static const char pad[] = " ";
@@ -3097,7 +3079,7 @@ XS(XS_DBI_dispatch); /* prototype to pass
-Wmissing-prototypes */
XS(XS_DBI_dispatch)
{
dXSARGS;
- dPERINTERP;
+ dMY_CXT;
SV *h = ST(0); /* the DBI handle we are working with */
SV *st1 = ST(1); /* used in debugging */
@@ -4295,6 +4277,8 @@ PROTOTYPES: DISABLE
BOOT:
(void)cv;
(void)items; /* avoid 'unused variable' warning */
+ MY_CXT_INIT;
+ (void)MY_CXT; /* avoid 'unused variable' warning */
dbi_bootinit(NULL);
@@ -4395,9 +4379,14 @@ constant()
void
_clone_dbis()
CODE:
- dPERINTERP;
+ dMY_CXT;
+ dbistate_t * parent_dbis = DBIS;
+
(void)cv;
- dbi_bootinit(DBIS);
+ {
+ MY_CXT_CLONE;
+ }
+ dbi_bootinit(parent_dbis);
void
@@ -4408,7 +4397,7 @@ _new_handle(class, parent, attr_ref, imp_datasv,
imp_class)
SV * imp_datasv
SV * imp_class
PPCODE:
- dPERINTERP;
+ dMY_CXT;
HV *outer;
SV *outer_ref;
HV *class_stash = gv_stashsv(class, GV_ADDWARN);
@@ -4521,7 +4510,7 @@ _install_method(dbi_class, meth_name, file,
attribs=Nullsv)
SV * attribs
CODE:
{
- dPERINTERP;
+ dMY_CXT;
/* install another method name/interface for the DBI dispatcher */
SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) :
Nullsv;
CV *cv;
@@ -4582,7 +4571,7 @@ trace(class, level_sv=&PL_sv_undef, file=Nullsv)
_debug_dispatch = 1
CODE:
{
- dPERINTERP;
+ dMY_CXT;
IV level;
if (!DBIS) {
ix=ix; /* avoid 'unused variable' warnings */
@@ -4638,7 +4627,7 @@ _svdump(sv)
SV * sv
CODE:
{
- dPERINTERP;
+ dMY_CXT;
(void)cv;
PerlIO_printf(DBILOGFP, "DBI::_svdump(%s)", neatsvpv(sv,0));
#ifdef DEBUGGING
@@ -4766,7 +4755,7 @@ void
FETCH(sv)
SV * sv
CODE:
- dPERINTERP;
+ dMY_CXT;
/* Note that we do not come through the dispatcher to get here. */
char *meth = SvPV_nolen(SvRV(sv)); /* what should this tie do ? */
char type = *meth++; /* is this a $ or & style */
@@ -5386,7 +5375,7 @@ trace_msg(sv, msg, this_trace=1)
PerlIO *pio;
CODE:
{
- dPERINTERP;
+ dMY_CXT;
(void)cv;
if (SvROK(sv)) {
D_imp_xxh(sv);
diff --git a/DBI.pm b/DBI.pm
index 511fe4d..551f6a0 100644
--- a/DBI.pm
+++ b/DBI.pm
@@ -520,10 +520,8 @@ END {
sub CLONE {
- my $olddbis = $DBI::_dbistate;
_clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
- DBI->trace_msg(sprintf "CLONE DBI for new thread %s\n",
- $DBI::PurePerl ? "" : sprintf("(dbis %x -> %x)",$olddbis,
$DBI::_dbistate));
+ DBI->trace_msg("CLONE DBI for new thread\n");
while ( my ($driver, $drh) = each %DBI::installed_drh) {
no strict 'refs';
next if defined &{"DBD::${driver}::CLONE"};
diff --git a/DBI.xs b/DBI.xs
index 887111d..dc7659f 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -88,8 +88,6 @@ static GV* inner_method_lookup(pTHX_ HV *stash, CV *cv,
const char *meth_na
char *neatsvpv _((SV *sv, STRLEN maxlen));
SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void
*foo);
-DBISTATE_DECLARE;
-
struct imp_drh_st { dbih_drc_t com; };
struct imp_dbh_st { dbih_dbc_t com; };
struct imp_sth_st { dbih_stc_t com; };
@@ -287,13 +285,20 @@ typedef struct {
START_MY_CXT
-#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
-# undef DBIS
-# define DBIS (MY_CXT.dbi_state)
-#endif
+#undef DBIS
+#define DBIS (MY_CXT.dbi_state)
#define g_dbi_last_h (MY_CXT.dbi_last_h)
+/* allow the 'static' dbi_state struct to be accessed from other files */
+dbistate_t**
+_dbi_state_lval(pTHX)
+{
+ dMY_CXT;
+ return &(MY_CXT.dbi_state);
+}
+
+
/* --- */
static void *
@@ -498,15 +503,7 @@ dbi_bootinit(dbistate_t * parent_dbis)
dbistate_t* DBISx;
DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st));
-
- /* publish address of dbistate so dynaloaded DBD's can find it,
- * taking care to store the value in the same way it'll be used
- * to avoid problems on some architectures, for example see
- * http://rt.cpan.org/Public/Bug/Display.html?id=32309
- */
- sv_setiv(get_sv(DBISTATE_PERLNAME, GV_ADDMULTI), 0); /* force SvIOK */
DBIS = DBISx;
- DBIS_PUBLISHED_LVALUE = DBISx;
/* store version and size so we can spot DBI/DBD version mismatch */
DBIS->check_version = check_version;
@@ -524,12 +521,6 @@ dbi_bootinit(dbistate_t * parent_dbis)
DBIS->thr_owner = PERL_GET_THX;
#endif
- DBISTATE_INIT; /* check DBD code to set DBIS from DBISTATE_PERLNAME */
-
- if (DBIS_TRACE_LEVEL > 9) {
- sv_dump(DBISTATE_ADDRSV);
- }
-
/* store some function pointers so DBD's can call our functions */
DBIS->getcom = dbih_getcom;
DBIS->clearcom = dbih_clearcom;
@@ -4280,6 +4271,9 @@ BOOT:
MY_CXT_INIT;
(void)MY_CXT; /* avoid 'unused variable' warning */
dbi_bootinit(NULL);
+ /* make this sub into a fake XS so it can bee seen by DBD::* modules;
+ * never actually call it as an XS sub, or it will crash and burn! */
+ (void) newXS("DBI::_dbi_state_lval", (XSUBADDR_t)_dbi_state_lval,
__FILE__);
I32
diff --git a/DBIXS.h b/DBIXS.h
index 7502af8..22a18de 100644
--- a/DBIXS.h
+++ b/DBIXS.h
@@ -467,8 +467,6 @@ struct dbistate_st {
#define set_attr(h, k, v) set_attr_k(h, k, 0, v)
#define get_attr(h, k) get_attr_k(h, k, 0)
-#define DBISTATE_PERLNAME "DBI::_dbistate"
-#define DBISTATE_ADDRSV (get_sv(DBISTATE_PERLNAME, 0x05))
#define DBILOGFP (DBIS->logfp)
#ifdef IN_DBI_XS
#define DBILOGMSG (dbih_logmsg)
@@ -476,28 +474,45 @@ struct dbistate_st {
#define DBILOGMSG (DBIS->logmsg)
#endif
-
/* --- perl object (ActiveState) / multiplicity hooks and hoops --- */
/* note that USE_ITHREADS implies MULTIPLICITY */
-#define DBIS_PUBLISHED_LVALUE (*(INT2PTR(dbistate_t**,
&SvIVX(DBISTATE_ADDRSV))))
+
+typedef dbistate_t** (*_dbi_state_lval_t)(pTHX);
+
+# define _DBISTATE_DECLARE_COMMON \
+ static _dbi_state_lval_t dbi_state_lval_p = 0; \
+ static dbistate_t** dbi_get_state(pTHX) { \
+ if (!dbi_state_lval_p) { \
+ CV *cv = get_cv("DBI::_dbi_state_lval", 0); \
+ if (!cv) \
+ croak("Unable to get DBI state function. DBI not loaded."); \
+ dbi_state_lval_p = (_dbi_state_lval_t)CvXSUB(cv); \
+ } \
+ return dbi_state_lval_p(aTHX); \
+ } \
+ typedef int dummy_dbistate /* keep semicolon from feeling lonely */
+
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
-# define DBISTATE_DECLARE typedef int dummy_dbistate /* keep semicolon from
feeling lonely */
-# define DBISTATE_INIT_DBIS typedef int dummy_dbistate2; /* keep semicolon
from feeling lonely */
+# define DBISTATE_DECLARE _DBISTATE_DECLARE_COMMON
+# define _DBISTATE_INIT_DBIS
# undef DBIS
-# define DBIS DBIS_PUBLISHED_LVALUE
-# define dbis DBIS_PUBLISHED_LVALUE /* temp for old drivers using 'dbis'
instead of 'DBIS' */
+# define DBIS (*dbi_get_state(aTHX))
+# define dbis DBIS /* temp for old drivers using 'dbis' instead of 'DBIS' */
#else /* plain and simple non perl object / multiplicity case */
-# define DBISTATE_DECLARE static dbistate_t *DBIS
-# define DBISTATE_INIT_DBIS (DBIS = DBIS_PUBLISHED_LVALUE)
+# define DBISTATE_DECLARE \
+ static dbistate_t *DBIS; \
+ _DBISTATE_DECLARE_COMMON
+
+# define _DBISTATE_INIT_DBIS DBIS = *dbi_get_state(aTHX);
#endif
# define DBISTATE_INIT { /* typically use in BOOT: of XS file */ \
- DBISTATE_INIT_DBIS; \
+ _DBISTATE_INIT_DBIS \
if (DBIS == NULL) \
- croak("Unable to get DBI state from %s at %p. DBI not loaded.",
DBISTATE_PERLNAME, (void*)DBISTATE_ADDRSV); \
+ croak("Unable to get DBI state. DBI not loaded."); \
DBIS->check_version(__FILE__, DBISTATE_VERSION, sizeof(*DBIS),
NEED_DBIXS_VERSION, \
sizeof(dbih_drc_t), sizeof(dbih_dbc_t), sizeof(dbih_stc_t),
sizeof(dbih_fdc_t) \
); \
