expand -DDEBUG_LEAKING_SCALARS to instrument the creation of each SV

p4raw-id: //depot/perl@24088

diff --git a/dump.c b/dump.c
index 8143bfb..9acd3c6 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1203,6 +1203,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     sv_catpv(d, ")");
     s = SvPVX(d);
 
+#ifdef DEBUG_LEAKING_SCALARS
+    Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
+       sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
+       sv->sv_debug_line,
+       sv->sv_debug_inpad ? "for" : "by",
+       sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
+       sv->sv_debug_cloned ? " (cloned)" : "");
+#endif
     Perl_dump_indent(aTHX_ level, file, "SV = ");
     switch (type) {
     case SVt_NULL:

diff --git a/ext/Devel/Peek/t/Peek.t b/ext/Devel/Peek/t/Peek.t
index 8d7189e..ac57026 100644 (file)
--- a/ext/Devel/Peek/t/Peek.t
+++ b/ext/Devel/Peek/t/Peek.t
@@ -28,6 +28,8 @@ sub do_test {
            local $/;
            $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
            $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
+           # handle DEBUG_LEAKING_SCALARS prefix
+           $pattern =~ s/^(\s*)(SV =.* at )/$1ALLOCATED at .*?\n$1$2/mg;
            print $pattern, "\n" if $DEBUG;
            my $dump = <IN>;
            print $dump, "\n"    if $DEBUG;

diff --git a/pad.c b/pad.c
index 3182ac8..b0cac8d 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -434,7 +434,11 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
          "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
          PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
          PL_op_name[optype]));
+#ifdef DEBUG_LEAKING_SCALARS
+    sv->sv_debug_optype = optype;
+    sv->sv_debug_inpad = 1;
     return (PADOFFSET)retval;
+#endif
 }
 
 /*

diff --git a/perl.c b/perl.c
index 9d3ecf4..118c1f4 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -827,8 +827,16 @@ perl_destruct(pTHXx)
                if (SvTYPE(sv) != SVTYPEMASK) {
                    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
                        " flags=0x08%"UVxf
-                       " refcnt=%"UVuf pTHX__FORMAT "\n",
-                       sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+                       " refcnt=%"UVuf pTHX__FORMAT "\n"
+                       "\tallocated at %s:%d %s %s%s\n",
+                       sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
+                       sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
+                       sv->sv_debug_line,
+                       sv->sv_debug_inpad ? "for" : "by",
+                       sv->sv_debug_optype ?
+                           PL_op_name[sv->sv_debug_optype]: "(none)",
+                       sv->sv_debug_cloned ? " (cloned)" : ""
+                   );
                }
            }
        }

diff --git a/pod/perlhack.pod b/pod/perlhack.pod
index 5e188c0..78226bd 100644 (file)
--- a/pod/perlhack.pod
+++ b/pod/perlhack.pod
@@ -2310,10 +2310,13 @@ documentation for more information. Also, spawned threads do the
 equivalent of setting this variable to the value 1.)
 
 If, at the end of a run you get the message I<N scalars leaked>, you can
-recompile with C<-DDEBUG_LEAKING_SCALARS>, which will cause
-the addresses of all those leaked SVs to be dumped; 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.
+recompile with C<-DDEBUG_LEAKING_SCALARS>, which will cause the addresses
+of all those leaked SVs to be dumped along with details as to where each
+SV was originally allocated. This information is also displayed by
+Devel::Peek. Note that the extra details recorded with each SV increases
+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.
 
 =head2 Profiling
 

diff --git a/sv.c b/sv.c
index ee631e5..37edaf8 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -165,8 +165,19 @@ Public API:
  * "A time to plant, and a time to uproot what was planted..."
  */
 
+#ifdef DEBUG_LEAKING_SCALARS
+#  ifdef NETWARE
+#    define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
+#  else
+#    define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
+#  endif
+#else
+#  define FREE_SV_DEBUG_FILE(sv)
+#endif
+
 #define plant_SV(p) \
     STMT_START {                                       \
+       FREE_SV_DEBUG_FILE(p);                          \
        SvANY(p) = (void *)PL_sv_root;                  \
        SvFLAGS(p) = SVTYPEMASK;                        \
        PL_sv_root = (p);                               \
@@ -200,6 +211,17 @@ S_new_SV(pTHX)
     SvANY(sv) = 0;
     SvREFCNT(sv) = 1;
     SvFLAGS(sv) = 0;
+    sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
+    sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
+        (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
+    sv->sv_debug_inpad = 0;
+    sv->sv_debug_cloned = 0;
+#  ifdef NETWARE
+    sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+#  else
+    sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
+#  endif
+    
     return sv;
 }
 #  define new_SV(p) (p)=S_new_SV(aTHX)
@@ -5822,7 +5844,14 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
     SvREFCNT(sv) = 0;
     sv_clear(sv);
     assert(!SvREFCNT(sv));
+#ifdef DEBUG_LEAKING_SCALARS
+    sv->sv_flags  = nsv->sv_flags;
+    sv->sv_any    = nsv->sv_any;
+    sv->sv_refcnt = nsv->sv_refcnt;
+#else
     StructCopy(nsv,sv,SV);
+#endif
+
 #ifdef PERL_COPY_ON_WRITE
     if (SvIsCOW_normal(nsv)) {
        /* We need to follow the pointers around the loop to make the
@@ -10727,6 +10756,19 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 
     /* create anew and remember what it is */
     new_SV(dstr);
+
+#ifdef DEBUG_LEAKING_SCALARS
+    dstr->sv_debug_optype = sstr->sv_debug_optype;
+    dstr->sv_debug_line = sstr->sv_debug_line;
+    dstr->sv_debug_inpad = sstr->sv_debug_inpad;
+    dstr->sv_debug_cloned = 1;
+#  ifdef NETWARE
+    dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+#  else
+    dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
+#  endif
+#endif
+
     ptr_table_store(PL_ptr_table, sstr, dstr);
 
     /* clone */
@@ -11540,6 +11582,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
 #  ifdef DEBUGGING
     Poison(my_perl, 1, PerlInterpreter);
+    PL_op = Nullop;
+    PL_curcop = Nullop;
     PL_markstack = 0;
     PL_scopestack = 0;
     PL_savestack = 0;
@@ -11572,6 +11616,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
 #    ifdef DEBUGGING
     Poison(my_perl, 1, PerlInterpreter);
+    PL_op = Nullop;
+    PL_curcop = Nullop;
     PL_markstack = 0;
     PL_scopestack = 0;
     PL_savestack = 0;

diff --git a/sv.h b/sv.h
index 9fe3657..05c4449 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -68,6 +68,13 @@ struct STRUCT_SV {           /* struct sv { */
     void*      sv_any;         /* pointer to something */
     U32                sv_refcnt;      /* how many references to us */
     U32                sv_flags;       /* what we are */
+#ifdef DEBUG_LEAKING_SCALARS
+    unsigned   sv_debug_optype:9;      /* the type of OP that allocated us */
+    unsigned   sv_debug_inpad:1;       /* was allocated in a pad for an OP */
+    unsigned   sv_debug_cloned:1;      /* was cloned for an ithread */
+    unsigned   sv_debug_line:16;       /* the line where we were allocated */
+    char *     sv_debug_file;          /* the file where we were allocated */
+#endif
 };
 
 struct gv {