This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add SV allocation tracing to -Dm and PERL_MEM_LOG
authorMarcus Holland-Moritz <mhx-perl@gmx.net>
Wed, 22 Oct 2008 01:37:31 +0000 (03:37 +0200)
committerMarcus Holland-Moritz <mhx-perl@gmx.net>
Fri, 24 Oct 2008 16:35:48 +0000 (16:35 +0000)
Message-ID: <20081022013731.23b5a2e5@r2d2>

p4raw-id: //depot/perl@34568

embed.fnc
handy.h
intrpvar.h
perl.c
pod/perlhack.pod
pod/perlrun.pod
sv.c
sv.h
util.c

index 031a8e6..d7a0ddb 100644 (file)
--- 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 (file)
--- 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
index 4a62779..3a55eb9 100644 (file)
@@ -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 (file)
--- 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",
index cf38f03..fcd4a87 100644 (file)
@@ -3196,6 +3196,27 @@ memory usage, so it shouldn't be used in production environments. It also
 converts C<new_SV()> 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<new_SV()> and make it
+break only when C<PL_sv_serial> 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<malloc()>,
 while the C<PERL_MEM_LOG> is at the level of C<New()>).
 
+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<PERL_MEM_LOG> and/or
+C<PERL_SV_LOG> 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.
index 2a53ec7..c2b5393 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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 (file)
--- 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 */
 
 /*