[perl #25237] Memory Leak when Recursively Traversing Circular Datastructures
David Jantzen Via Rt
# Please include the string: [perl #25237]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=25237 >
This is a bug report for perl from djan...@indiana.edu,
generated with the help of perlbug 1.33 running under perl v5.6.1.
-----------------------------------------------------------------
[Please enter your report here]
The full post and discussion can be found at:
http://perlmonks.org/index.pl?node_id=319780
Further details are here:
http://perlmonks.org/index.pl?node_id=320069
I've managed to solve my own issues by making the problem subroutines
into iterative functions rather than recursive, but others may yet be
bitten.
Code demonstrating the bug follows:
use strict;
use warnings;
use Data::Structure::Util(qw/has_circular_ref circular_off/);
# BEGIN NETWORK CLASS
package Network;
sub new
{
my ($class) = @_;
bless { _nodes => [] }, $class;
}
sub node
{
my ($self, $index) = @_;
return $self->{_nodes}[$index];
}
sub add_node
{
my ($self) = @_;
push @{$self->{_nodes}}, Node->new();
}
# CAUSE OF THE TROUBLE
sub DFS
{
my ($self, $node, $sub) = @_;
my ($explored, $do_search);
$do_search = sub {
my ($node) = @_;
$sub->($node);
$explored->{$node->{_id}}++;
foreach my $link (@{$node->{_outlinks}}) {
$do_search->($link->{_to}) unless ($explored->{$link->{_id}});
}
};
$do_search->($node);
}
sub transitive_closure_DFS
{
my ($self, $node) = @_;
my $nodes = [];
my $search = sub { push @$nodes, $_[0] };
$self->DFS($node, $search);
return $nodes;
}
sub DESTROY
{
my ($self) = @_;
print "DESTROYING $self\n";
foreach my $node (@{$self->{_nodes}}) {
$node->delete_links();
}
}
# BEGIN NODE CLASS
package Node;
{
my $_nodecount = 0;
sub _nextID { return ++$_nodecount }
}
sub new
{
my ($class) = @_;
bless { _id => _nextID(), _outlinks => [] }, $class;
}
sub add_link_to
{
my ($self, $target) = @_;
push @{$self->{_outlinks}}, Link->new($target);
}
sub delete_links
{
my ($self) = @_;
delete $self->{_outlinks};
}
sub DESTROY
{
my ($self) = @_;
print "DESTROYING $self $self->{_id}\n";
}
# BEGIN LINK CLASS
package Link;
{
my $_linkcount = 0;
sub _nextID { return ++$_linkcount }
}
sub new
{
my ($class, $target) = @_;
bless { _id => _nextID(),
_to => $target
}, $class;
}
sub delete_node
{
my ($self) = @_;
delete $self->{_to};
}
sub DESTROY
{
my ($self) = @_;
print "DESTROYING $self $self->{_id}\n";
$self->delete_node(); # EVEN THIS DOESN'T KILL THE REMAINING NODES
}
package main;
sub build_graph
{
my $network = Network->new();
for (0..2) { $network->add_node(); }
$network->node(0)->add_link_to($network->node(1));
$network->node(0)->add_link_to($network->node(2));
$network->node(1)->add_link_to($network->node(2));
$network->node(2)->add_link_to($network->node(1));
my $neighbors = $network->transitive_closure_DFS($network->node(0));
print "Neighbors\n";
print " $_ ID $_->{_id}\n" for (@$neighbors);
circular_off($network); # THIS DOES NOT AFFECT BEHAVIOR, WHY?
}
print "BUILDING GRAPH\n";
build_graph();
print "SHOULD BE THE LAST THING PRINTED, HOWEVER ...\n";
__END__
[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
category=core
severity=medium
---
Site configuration information for perl v5.6.1:
Configured by stassenm at Wed Dec 12 22:46:50 EST 2001.
Summary of my perl5 (revision 5.0 version 6 subversion 1) configuration:
Platform:
osname=solaris, osvers=2.7, archname=sun4-solaris
uname='sunos bell 5.7 generic_106541-16 sun4u sparc sunw,ultra-250 '
config_args='-Dcc=gcc -Dprefix=/usr/local'
hint=recommended, useposix=true, d_sigaction=define
usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
useperlio=undef d_sfio=undef uselargefiles=define usesocks=undef
use64bitint=undef use64bitall=undef uselongdouble=undef
Compiler:
cc='gcc', ccflags ='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-O2',
cppflags='-fno-strict-aliasing -I/usr/local/include'
ccversion='', gccversion='2.95.2 19991024 (release)', gccosandvers='solaris2.7'
intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=4321
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
alignbytes=8, usemymalloc=y, prototype=define
Linker and Libraries:
ld='gcc', ldflags =' -L/usr/local/lib '
libpth=/usr/local/lib /usr/lib /usr/ccs/lib
libs=-lsocket -lnsl -ldl -lm -lc
perllibs=-lsocket -lnsl -ldl -lm -lc
libc=/lib/libc.so, so=so, useshrplib=false, libperl=libperl.a
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' '
cccdlflags='-fPIC', lddlflags='-G -L/usr/local/lib'
Locally applied patches:
---
@INC for perl v5.6.1:
/usr/local/lib/perl5/5.6.1/sun4-solaris
/usr/local/lib/perl5/5.6.1
/usr/local/lib/perl5/5.6.1/site_perl/sun4-solaris
/usr/local/lib/perl5/5.6.1/site_perl
/usr/local/lib/perl5/5.6.1/site_perl
.
---
Environment for perl v5.6.1:
HOME=/home/djantzen
LANG (unset)
LANGUAGE (unset)
LD_LIBRARY_PATH (unset)
LOGDIR (unset)
PATH=/home/djantzen/kb3/bin:/home/djantzen/kb3/adm:/home/djantzen/kb3/janis/bin:/usr/local/bin:/usr/bin:/usr/dt/bin:/usr/X/bin:/opt/NSCPcom:/usr/ccs/bin:/opt/krb5/bin:/kb/bin:/kb/adm:/oracle/app/oracle/product/8.1.7/bin:/home/djantzen/bin:/opt/ORBacus/bin:/usr/sbin:/usr/oasys/bin/:/home/djantzen/kb3/Panoply/bin:/home/djantzen/bin:/opt/ORBacus/bin:/usr/sbin:/usr/oasys/bin/:/home/djantzen/kb3/Panoply/bin:/home/djantzen/kb3/adm/dev/apache/bin
PERL_BADLANG (unset)
SHELL=/usr/local/bin/bash
Dave Mitchell
> Code demonstrating the bug follows:
This code is too long for me to have studied it fully, but I strongly
suspect the following bit is the problem:
> sub DFS
> {
> my ($self, $node, $sub) = @_;
>
> my ($explored, $do_search);
>
> $do_search = sub {
^^^^^^^^^^
>
> my ($node) = @_;
> $sub->($node);
> $explored->{$node->{_id}}++;
> foreach my $link (@{$node->{_outlinks}}) {
> $do_search->($link->{_to}) unless ($explored->{$link->{_id}});
^^^^^^^^^^
> }
> };
> $do_search->($node);
> }
You have managed to create a closure which closes over itself - ie
$do_search is a reference to a closure, and that closure itself has a
reference to $do_search. It's a gloried version of C<push @$a, $a>.
This simpler example demonstrates the phenomenom:
sub X::DESTROY { print "DESTROY $_[0]\n" }
sub f {
my $x = bless [], 'X';
my $anon;
$anon = sub { $x, $anon };
}
f();
print "outside f()\n";
which outputs.
outside f()
DESTROY X=ARRAY(0x8180170)
In your sub DFS, adding the following line makes the problem go away:
}
};
$do_search->($node);
+ undef $do_search;
}
--
"Do not dabble in paradox, Edward, it puts you in danger of fortuitous
wit." -- Lady Croom - Arcadia