Recent problems with threads and memory pools on Win32 led to a couple
of patches being produced by Jan Dubois to help reproduce the problems
in non-Win32 land.
Specifically, one excellent patch was intended to reproduce any "free to
wrong pool" errors:
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-01/msg00748.html
and another more problematic patch was intended to catch such errors
earlier on:
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-01/msg00773.html
In a recent discussion elsewhere regarding the old "free to wrong pool"
error with DBD-mysql on Win32, Jan suggested just using the first two
hunks of the sv.c changes from the second patch; the rest of it doesn't
work quite right.
With the whole of the first patch (attached here as patch1.txt) plus
those first two hunks of the sv.c changes from the second patch
(attached here as patch2.txt) applied to perl-5.8.3, I find that mp2's
t/perl/ithreads.t test now fails within Perl_safesysfree() at a point
introduced by the second patch. (Stack trace below. I'm using Apache
2.0.48, mp2 CVS, Perl 5.8.3.)
If I just undo the second patch but leave the first patch applied then
the whole mp2 test suite runs fine.
Has the application of the second patch uncovered a bug that's waiting
to bite us later, or is the failure caused by the second patch itself?
- Steve
=====
Perl_safesysfree(void * 0x0679c7dc) line 165 + 3 bytes
Perl_sv_free(interpreter * 0x04cd4bd4, sv * 0x0679c7e0) line 5374 + 9 bytes
S_hv_fetch_common(interpreter * 0x04cd4bd4, hv * 0x05ab9940, sv *
0x00000000, const char * 0x029b7460 `string', unsigned int 12, int 0,
int 9, sv * 0x07697400, unsigned long 1956197456) line 685 + 16 bytes
Perl_hv_store(interpreter * 0x04cd4bd4, hv * 0x05ab9940, const char *
0x029b7460 `string', long 12, sv * 0x07697400, unsigned long 0) line 221
+ 35 bytes
Perl_ithread_set(interpreter * 0x04cd4bd4, ithread_s * 0x03770974) line
75 + 37 bytes
Perl_ithread_create(interpreter * 0x04cd4bd4, sv * 0x00000000, char *
0x04f84070, sv * 0x04faa2f8, sv * 0x05e38d78) line 469 + 13 bytes
XS_threads_new(interpreter * 0x04cd4bd4, cv * 0x055d7f78) line 644 + 36
bytes
Perl_pp_entersub(interpreter * 0x04cd4bd4) line 2840 + 16 bytes
Perl_runops_debug(interpreter * 0x04cd4bd4) line 1438 + 13 bytes
S_call_body(interpreter * 0x04cd4bd4, op * 0x08b2fd58, int 0) line 2221
+ 13 bytes
Perl_call_sv(interpreter * 0x04cd4bd4, sv * 0x06a0da08, long 4) line
2139 + 15 bytes
modperl_callback(interpreter * 0x04cd4bd4, modperl_handler_t *
0x092e25d8, apr_pool_t * 0x092da518, request_rec * 0x092da550,
server_rec * 0x0028cc30, av * 0x061bfb38) line 69 + 17 bytes
modperl_callback_run_handlers(int 6, int 4, request_rec * 0x092da550,
conn_rec * 0x00000000, server_rec * 0x0028cc30, apr_pool_t * 0x00000000,
apr_pool_t * 0x00000000, apr_pool_t * 0x00000000, int 1) line 227 + 35 bytes
modperl_callback_per_dir(int 6, request_rec * 0x092da550, int 1) line
301 + 34 bytes
modperl_response_handler_run(request_rec * 0x092da550, int 1) line 822 +
13 bytes
modperl_response_handler(request_rec * 0x092da550) line 844 + 11 bytes
ap_run_handler(request_rec * 0x092da550) line 195 + 78 bytes
ap_invoke_handler(request_rec * 0x092da550) line 401 + 9 bytes
ap_process_request(request_rec * 0x092da550) line 288 + 9 bytes
ap_process_http_connection(conn_rec * 0x092d4578) line 293 + 9 bytes
ap_run_process_connection(conn_rec * 0x092d4578) line 85 + 78 bytes
ap_process_connection(conn_rec * 0x092d4578, void * 0x092d44a8) line 213
worker_main(long 1) line 731
_threadstartex(void * 0x0028d418) line 212 + 13 bytes
KERNEL32! 77e7d33b()
=====
------------------------------------------------
Radan Computational Ltd.
The information contained in this message and any files transmitted with it are
confidential and intended for the addressee(s) only. If you have received this
message in error or there are any problems, please notify the sender immediately. The
unauthorized use, disclosure, copying or alteration of this message is strictly
forbidden. Note that any views or opinions presented in this email are solely those
of the author and do not necessarily represent those of Radan Computational Ltd. The
recipient(s) of this message should check it and any attached files for viruses: Radan
Computational will accept no liability for any damage caused by any virus transmitted
by this email.
--- util.c.orig 2004-01-30 12:38:09.307855400 +0000
+++ util.c 2004-01-30 12:48:52.479273800 +0000
@@ -60,6 +60,9 @@
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ size += sizeof(aTHX);
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: malloc");
@@ -67,8 +70,13 @@
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our
system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != Nullch) {
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ *(PerlInterpreter**)ptr = aTHX;
+ ptr = (Malloc_t)((char*)ptr+sizeof(aTHX));
+#endif
return ptr;
+ }
else if (PL_nomemok)
return Nullch;
else {
@@ -104,6 +112,15 @@
if (!where)
return safesysmalloc(size);
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ where = (Malloc_t)((char*)where-sizeof(aTHX));
+ size += sizeof(aTHX);
+ if (*(PerlInterpreter**)where != aTHX) {
+ int *nowhere = NULL;
+ PerlIO_printf(Perl_debug_log, "realloc from wrong pool");
+ *nowhere = 0;
+ }
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: realloc");
@@ -114,8 +131,12 @@
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld)
rfree\n",PTR2UV(where),(long)PL_an++));
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != Nullch) {
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ ptr = (Malloc_t)((char*)ptr+sizeof(aTHX));
+#endif
return ptr;
+ }
else if (PL_nomemok)
return Nullch;
else {
@@ -131,11 +152,19 @@
Free_t
Perl_safesysfree(Malloc_t where)
{
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_CONTEXT) || defined(PERL_TRACK_MEMPOOL)
dTHX;
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld)
free\n",PTR2UV(where),(long)PL_an++));
if (where) {
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ where = (Malloc_t)((char*)where-sizeof(aTHX));
+ if (*(PerlInterpreter**)where != aTHX) {
+ int *nowhere = NULL;
+ PerlIO_printf(Perl_debug_log, "free from wrong pool");
+ *nowhere = 0;
+ }
+#endif
/*SUPPRESS 701*/
PerlMem_free(where);
}
@@ -161,11 +190,18 @@
Perl_croak_nocontext("panic: calloc");
#endif
size *= count;
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ size += sizeof(aTHX);
+#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our
system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
if (ptr != Nullch) {
memset((void*)ptr, 0, size);
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+ *(PerlInterpreter**)ptr = aTHX;
+ ptr = (Malloc_t)((char*)ptr+sizeof(aTHX));
+#endif
return ptr;
}
else if (PL_nomemok)
--- sv.c.orig 2004-01-30 12:37:57.729952700 +0000
+++ sv.c 2004-01-30 12:52:57.451105600 +0000
@@ -170,6 +170,21 @@
} STMT_END
+#if defined(PERL_IMPLICIT_CONTEXT) && defined(PERL_TRACK_MEMPOOL)
+STATIC SV*
+S_new_SV()
+{
+ SV* sv = safemalloc(sizeof(SV));
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ return sv;
+}
+
+# define new_SV(p) (p)=S_new_SV()
+# define del_SV(p) safefree((char*)p)
+#else
+
/* new_SV(): return a new, empty SV head */
#ifdef DEBUG_LEAKING_SCALARS
@@ -253,6 +268,8 @@
#endif /* DEBUGGING */
+#endif
+
/*
=head1 SV Manipulation Functions
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
