expand -DDEBUG_LEAKING_SCALARS to instrument the creation of each SV

p4raw-id: //depot/perl@24088

7 files changed, 84 insertions, 6 deletions

diff --git a/dump.c b/dump.c
index 8143bfbe71..9acd3c6a0e 100644
--- 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 8d7189ef6a..ac57026a8f 100644
--- 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 3182ac8591..b0cac8dc9a 100644
--- 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 9d3ecf4ca7..118c1f498d 100644
--- 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 5e188c08a0..78226bd662 100644
--- 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 ee631e51c2..37edaf8b7c 100644
--- 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 9fe365751b..05c44493f5 100644
--- 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 {