From: Marcus Holland-Moritz Date: Wed, 22 Oct 2008 01:37:31 +0000 (+0200) Subject: Add SV allocation tracing to -Dm and PERL_MEM_LOG X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d7a2c63ca1dd960ced99dbacbd31f848d2ffa77f;p=p5sagit%2Fp5-mst-13.2.git Add SV allocation tracing to -Dm and PERL_MEM_LOG Message-ID: <20081022013731.23b5a2e5@r2d2> p4raw-id: //depot/perl@34568 --- diff --git a/embed.fnc b/embed.fnc index 031a8e6..d7a0ddb 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1680,7 +1680,7 @@ s |bool |vdie_common |NULLOK const char *message|STRLEN msglen\ sr |char * |write_no_mem #if defined(PERL_MEM_LOG) && defined(PERL_MEM_LOG_STDERR) sn |void |mem_log_common |enum mem_log_type mlt|const UV n|const UV typesize \ - |NN const char *typename \ + |NN const char *typename|NULLOK const SV *sv \ |Malloc_t oldalloc|Malloc_t newalloc \ |NN const char *filename|const int linenumber \ |NN const char *funcname diff --git a/handy.h b/handy.h index c07350d..39e3ef8 100644 --- a/handy.h +++ b/handy.h @@ -773,9 +773,14 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int li enum mem_log_type { MLT_ALLOC, MLT_REALLOC, - MLT_FREE + MLT_FREE, + MLT_NEW_SV, + MLT_DEL_SV }; # endif +/* those are only used in sv.c */ +void Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname); +void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname); # endif #endif diff --git a/intrpvar.h b/intrpvar.h index 4a62779..3a55eb9 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -674,6 +674,10 @@ PERLVARI(Islab_count, U32, 0) /* Size of the array */ /* Can shared object be destroyed */ PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable)) +#ifdef DEBUG_LEAKING_SCALARS +PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */ +#endif + /* If you are adding a U8 or U16, check to see if there are 'Space' comments * above on where there are gaps which currently will be structure padding. */ diff --git a/perl.c b/perl.c index e3d0161..ba5a208 100644 --- a/perl.c +++ b/perl.c @@ -2961,7 +2961,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " o Method and overloading resolution", " c String/numeric conversions", " P Print profiling info, source file input state", - " m Memory allocation", + " m Memory and SV allocation", " f Format processing", " r Regular expression parsing and execution", " x Syntax tree dump", diff --git a/pod/perlhack.pod b/pod/perlhack.pod index cf38f03..fcd4a87 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -3196,6 +3196,27 @@ memory usage, so it shouldn't be used in production environments. It also converts C from a macro into a real function, so you can use your favourite debugger to discover where those pesky SVs were allocated. +If you see that you're leaking memory at runtime, but neither valgrind +nor C<-DDEBUG_LEAKING_SCALARS> will find anything, you're probably +leaking SVs that are still reachable and will be properly cleaned up +during destruction of the interpreter. In such cases, using the C<-Dm> +switch can point you to the source of the leak. If the executable was +built with C<-DDEBUG_LEAKING_SCALARS>, C<-Dm> will output SV allocations +in addition to memory allocations. Each SV allocation has a distinct +serial number that will be written on creation and destruction of the SV. +So if you're executing the leaking code in a loop, you need to look for +SVs that are created, but never destroyed between each cycle. If such an +SV is found, set a conditional breakpoint within C and make it +break only when C is equal to the serial number of the +leaking SV. Then you will catch the interpreter in exactly the state +where the leaking SV is allocated, which is sufficient in many cases to +find the source of the leak. + +As C<-Dm> is using the PerlIO layer for output, it will by itself +allocate quite a bunch of SVs, which are hidden to avoid recursion. +You can bypass the PerlIO layer if you use the SV logging provided +by C<-DPERL_MEM_LOG> instead. + =head2 PERL_MEM_LOG If compiled with C<-DPERL_MEM_LOG>, all Newx() and Renew() allocations @@ -3209,6 +3230,17 @@ This logging is somewhat similar to C<-Dm> but independent of C<-DDEBUGGING>, and at a higher level (the C<-Dm> is directly at the point of C, while the C is at the level of C). +In addition to memory allocations, SV allocations will be logged, just as +with C<-Dm>. However, since the logging doesn't use PerlIO, all SV allocations +are logged and no extra SV allocations are introduced by enabling the logging. +If compiled with C<-DDEBUG_LEAKING_SCALARS>, the serial number for each SV +allocation is also logged. + +You can control the logging from your environment if you compile with +C<-DPERL_MEM_LOG_ENV>. Then you need to explicitly set C and/or +C to a non-zero value to enable logging of memory and/or SV +allocations. + =head2 Profiling Depending on your platform there are various of profiling Perl. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 2a53ec7..c2b5393 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -395,7 +395,7 @@ B<-D14> is equivalent to B<-Dtls>): 16 o Method and overloading resolution 32 c String/numeric conversions 64 P Print profiling info, source file input state - 128 m Memory allocation + 128 m Memory and SV allocation 256 f Format processing 512 r Regular expression parsing and execution 1024 x Syntax tree dump diff --git a/sv.c b/sv.c index 33aa8ec..d64b85a 100644 --- a/sv.c +++ b/sv.c @@ -173,10 +173,24 @@ Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) } } +#ifdef PERL_MEM_LOG +# define MEM_LOG_NEW_SV(sv, file, line, func) \ + Perl_mem_log_new_sv(sv, file, line, func) +# define MEM_LOG_DEL_SV(sv, file, line, func) \ + Perl_mem_log_del_sv(sv, file, line, func) +#else +# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP +# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP +#endif + #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) +# define DEBUG_SV_SERIAL(sv) \ + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ + PTR2UV(sv), (long)(sv)->sv_debug_serial)) #else # define FREE_SV_DEBUG_FILE(sv) +# define DEBUG_SV_SERIAL(sv) NOOP #endif #ifdef PERL_POISON @@ -202,6 +216,8 @@ Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) #define plant_SV(p) \ STMT_START { \ const U32 old_flags = SvFLAGS(p); \ + MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ + DEBUG_SV_SERIAL(p); \ FREE_SV_DEBUG_FILE(p); \ POSION_SV_HEAD(p); \ SvFLAGS(p) = SVTYPEMASK; \ @@ -247,7 +263,7 @@ S_more_sv(pTHX) #ifdef DEBUG_LEAKING_SCALARS /* provide a real function for a debugger to play with */ STATIC SV* -S_new_SV(pTHX) +S_new_SV(pTHX_ const char *file, int line, const char *func) { SV* sv; @@ -268,10 +284,16 @@ S_new_SV(pTHX) sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; - + + sv->sv_debug_serial = PL_sv_serial++; + + MEM_LOG_NEW_SV(sv, file, line, func); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + return sv; } -# define new_SV(p) (p)=S_new_SV(aTHX) +# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) #else # define new_SV(p) \ @@ -283,6 +305,7 @@ S_new_SV(pTHX) SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ } STMT_END #endif diff --git a/sv.h b/sv.h index f6f1c2b..40ec242 100644 --- a/sv.h +++ b/sv.h @@ -121,6 +121,7 @@ struct STRUCT_SV { /* struct sv { */ PERL_BITFIELD32 sv_debug_inpad:1; /* was allocated in a pad for an OP */ PERL_BITFIELD32 sv_debug_cloned:1; /* was cloned for an ithread */ PERL_BITFIELD32 sv_debug_line:16; /* the line where we were allocated */ + U32 sv_debug_serial; /* serial number of sv allocation */ char * sv_debug_file; /* the file where we were allocated */ #endif }; diff --git a/util.c b/util.c index baebeb1..1560fb5 100644 --- a/util.c +++ b/util.c @@ -5519,9 +5519,10 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. * * PERL_MEM_LOG_ENV: if defined, during run time the environment - * variable PERL_MEM_LOG will be consulted, and if the integer value - * of that is true, the logging will happen. (The default is to - * always log if the PERL_MEM_LOG define was in effect.) + * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and + * if the integer value of that is true, the logging will happen. + * (The default is to always log if the PERL_MEM_LOG define was + * in effect.) * * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged * before every memory logging entry. This can be turned off at run @@ -5546,14 +5547,23 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #endif #ifdef PERL_MEM_LOG_STDERR + +# ifdef DEBUG_LEAKING_SCALARS +# define SV_LOG_SERIAL_FMT " [%lu]" +# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial +# else +# define SV_LOG_SERIAL_FMT +# define _SV_LOG_SERIAL_ARG(sv) +# endif + static void -S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *typename, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) { # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) const char *s; # endif # ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); + s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG"); if (s ? atoi(s) : 0) # endif { @@ -5616,6 +5626,14 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const cha filename, linenumber, funcname, PTR2UV(oldalloc)); break; + case MLT_NEW_SV: + case MLT_DEL_SV: + len = my_snprintf(buf, sizeof(buf), + "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", + mlt == MLT_NEW_SV ? "new" : "del", + filename, linenumber, funcname, + PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); + break; } PerlLIO_write(fd, buf, len); } @@ -5627,7 +5645,7 @@ Malloc_t Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) { #ifdef PERL_MEM_LOG_STDERR - mem_log_common(MLT_ALLOC, n, typesize, typename, NULL, newalloc, filename, linenumber, funcname); + mem_log_common(MLT_ALLOC, n, typesize, typename, NULL, NULL, newalloc, filename, linenumber, funcname); #endif return newalloc; } @@ -5636,7 +5654,7 @@ Malloc_t Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) { #ifdef PERL_MEM_LOG_STDERR - mem_log_common(MLT_REALLOC, n, typesize, typename, oldalloc, newalloc, filename, linenumber, funcname); + mem_log_common(MLT_REALLOC, n, typesize, typename, NULL, oldalloc, newalloc, filename, linenumber, funcname); #endif return newalloc; } @@ -5645,11 +5663,27 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) { #ifdef PERL_MEM_LOG_STDERR - mem_log_common(MLT_FREE, 0, 0, "", oldalloc, NULL, filename, linenumber, funcname); + mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); #endif return oldalloc; } +void +Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + +void +Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + #endif /* PERL_MEM_LOG */ /*