Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.pm line 380.

by faber (Acolyte)
on Dec 18, 2009 at 18:28 UTC ( #813410=perlquestion: print w/ replies, xml ) Need Help??
faber has asked for the wisdom of the Perl Monks concerning the following question:

Hi Folks,

So I'm a bit stumped here. I've got a simple forking server managed through a fork() wrapper module, there is nothing special here, the wrapper module (Ext::Fork) just manages queues and execute requests etc.

So here is where I'm at, with perl 5.8.8 5.8.9 5.10 and 5.10.1 I'm reliably seeing:

panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.p +m line 380.

Line 380 of Server.pm:

(%ch) = rfork_list_children(1);

rfork_list_children is exported from Ext::Fork:

sub rfork_list_children { my ($use_hash) = @_; if(!$Ext::Fork::POOL->{cidlist}){ return; } if($use_hash){ return %{ $Ext::Fork::POOL->{cidlist} }; } else { return keys %{ $Ext::Fork::POOL->{cidlist} }; } }

So the interesting bit is this code is repeatedly hit thousands of times prior to the panic, and it should never be reached in the event of $Ext::Fork::POOL->{cidlist}->{} is undefined.

Does anyone seen any no-no's here that I should be avoiding explicitly that can result in the above panic?

Thanks!

Comment on panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.pm line 380.
Select or Download Code
Re: panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.pm line 380.
by gmargo (Hermit) on Dec 18, 2009 at 22:35 UTC

    Where is "Ext::Fork"? I searched cannot find it. Give us a bit of code that we can run and then we can probably help.

      Ext::Fork is my own library, not published yet though will be Artistic 2 or GPL at some point.
      package Ext::Fork; # @@COPYRIGHT@@ $VERSION = '@@VERSION@@'; # Version number - cvs automagically updated. our $VERSION = '$Revision: 1.3 $'; use strict; use POSIX ('WNOHANG','setsid'); require Exporter; # Try and use high resolution timing if(eval 'use Time::HiRes qw(usleep);'){ $Ext::Fork::has_thr = 1 if !$Ext::Fork::no_thr; } # Exported routines our @ISA = ('Exporter'); our @EXPORT = qw( rfork rfork_wait rfork_init rfork_maxchildren rfork_errstr rfork_is_child rfork_has_children rfork_nonblocking rfork_daemonize rfork_sleep rfork_usleep rfork_ssleep rfork_active_children rfork_kill_children rfork_list_children rfork_child_dob ); # Defaults &rfork_init(); require 5.008; our $VERSION = '$Revision: 1.3 $'; =head1 NAME Ext::Fork - A simple library of routines to manage forking. =head1 DESCRIPTION This library functions much the same way as Proc::Fork except there ar +e many more options such as nonblocking forks, forks within forks, an +d high resolution timing =head1 SYNOPSIS #!/usr/bin/perl use Ext::Fork; use Fcntl ':flock'; # Initialize the system allowing 25 forks per rfork() level rfork_init(25); for(my $i = 0; $i < 100; $i++){ # Fork this if possible, if all avaliable fork slots are full # block until one becomes avaliable. rfork(sub { # Lock STDOUT for writing. flock(STDOUT, &LOCK_EX); # Print out a string. print STDOUT "Fork: $_\n"; # Unlock STDOUT. flock(STDOUT, &LOCK_UN); }); } # Wait until all forks have finished. rfork_wait(); =head1 METHODS Note - because of the nature of forking within perl. I've decided not +to make this code object based. Rather it uses direct function calls +which are exported to the global namespace Below is a list of these c +alls and how to access them. =head2 rfork(code, code, code) Provide managed forking functions. Returns nothing on error and sets the rfork_errstr error handler. if rfork() is called with in an rfork()ed process the calling rfork() +process will block until all children with in it die off. =cut sub rfork { if(!$Ext::Fork::POOL->{max_children}){ return rfork_errstr("The $Ext::Fork::POOL->{max_children} opti +on is required! Maybe you forgot to rfork_init()?"); } if(!defined $Ext::Fork::POOL->{children}){ $Ext::Fork::POOL->{children} = 0; } if(!defined $Ext::Fork::POOL->{max_children}){ $Ext::Fork::POOL->{max_children} = 0; } while(1){ if($Ext::Fork::POOL->{children} < $Ext::Fork::POOL->{max_child +ren}){ last; } if($Ext::Fork::has_thr){ rfork_usleep(500); } else { rfork_sleep(1); } } if($Ext::Fork::POOL->{is_child}){ $Ext::Fork::POOL->{has_children} = 1; } my $pid = fork; if($pid < 0){ return rfork_errstr('ERROR: fork: ' . $!); } elsif($pid){ $Ext::Fork::POOL->{cidlist}->{$pid} = time(); $Ext::Fork::POOL->{children}++; } else { rfork_init(); $Ext::Fork::POOL->{is_child} = 1; $SIG{PIPE} = 'IGNORE'; for my $code (@_){ if(ref($code) eq 'CODE'){ &{ $code }; } } exit(2); } if($Ext::Fork::POOL->{has_children} && !$Ext::Fork::POOL->{nonbloc +king}){ while(1){ last if !$Ext::Fork::POOL->{children}; if($Ext::Fork::has_thr){ rfork_usleep(500); } else { rfork_sleep(1); } } } return $pid; } =head2 rfork_nonblocking(BOOL) Set the rfork() behavior to nonblocking mode if <BOOL> is true, This w +ill result in the fork returning right away rather than waiting for a +ny possible children to die. =cut sub rfork_nonblocking { $Ext::Fork::POOL->{nonblocking} = $_[0]; } =head2 rfork_is_child() Return true if called with in a forked enviroment, otherwise return fa +lse. =cut sub rfork_is_child { return $Ext::Fork::POOL->{is_child}; } =head2 rfork_has_children() Return true if children exist with in a forked enviroment. =cut sub rfork_has_children { return $Ext::Fork::POOL->{has_children}; } =head2 rfork_errstr() Return the last error message. =cut sub _sigchld { while((my $p = waitpid(-1, WNOHANG)) > 0){ delete $Ext::Fork::POOL->{cidlist}->{$p}; $Ext::Fork::POOL->{children} -- if $Ext::Fork::POOL->{children +}; } # self reference $SIG{CHLD} = \&Ext::Fork::_sigchld; } =head2 rfork_init(children) Initialize the CHLD reaper with a maximum number of <childre> This should be called prior to any rfork() calls =cut sub rfork_init { $Ext::Fork::POOL = {}; $Ext::Fork::POOL->{children} = 0; $Ext::Fork::POOL->{cidlist} = {}; $Ext::Fork::POOL->{is_child} = 0; if($_[0]){ $Ext::Fork::POOL->{max_children} = $_[0]; $SIG{CHLD} = \&Ext::Fork::_sigchld; } } =head2 rfork_maxchildren(int) Set/Reset the maximum number of children allowed. =cut sub rfork_maxchildren { $Ext::Fork::POOL->{max_children} = $_[0] if $_[0]; } =head2 rfork_wait() Block until all rfork() children have died off unless rfork_nonblockin +g() is enabled. =cut sub rfork_wait { return 1 if $Ext::Fork::POOL->{nonblocking}; while(1){ last if !$Ext::Fork::POOL->{children}; if($Ext::Fork::has_thr){ rfork_usleep(500); } else { rfork_sleep(1); } } return 1; } =head2 rfork_active_children() Return the total number of active children. =cut sub rfork_active_children { return ($Ext::Fork::POOL->{children} ? $Ext::Fork::POOL->{children +} : 0); } =head2 rfork_daemonize(BOOL) Daemonize the the calling script. If <BOOL> is true write _ALL_ output to /dev/null. =cut sub rfork_daemonize { my $q = $_[0]; chdir('/') || die "Can't chdir to /: $!\n"; if(!$q){ open STDIN, '/dev/null' || die "Can't read /dev/null: $!\n" +; open STDOUT, '>/dev/null' || die "Can't write to /dev/null: $ +!\n"; open STDERR, '>&STDOUT' || die "Can't dup stdout: $!"; } defined(my $pid = fork) || die "Can't fork: $!\n"; exit(0) if $pid; setsid || die "Can't start a new session: $!\n"; } =head2 rfork_sleep(int) Provides an alarm safe sleep() wrapper. Beacuse we sleep() with in thi +s, ALRM will be issued with in the fork once the sleep cycle has comp +leted. This function wraps sleep with in a while() block and tests to + make sure that the seconds requested for the sleep were slept. Also, setting $Ext::Fork::select_sleep to a true value will bypass all + standard sleep() handling (including interuption handling) and use a + system select() call to preform a blocking timeout. This is useful o +n systems with a malfunctioning sleep() call. =cut sub rfork_sleep { my $sleep = $_[0]; return if $sleep !~ /^\d+$/; if($Ext::Fork::select_sleep){ select(undef, undef, undef, $sleep); return $sleep; } my $sleeper = 0; my $slept = 0; while(1){ if($sleeper < 0 || $sleep <= 0){ last; } elsif(!$sleeper) { $sleeper = $sleep; } my $remain = sleep( abs($sleeper) ); if($remain ne $sleeper && $remain < $sleep){ $slept += $remain; $sleeper = $sleeper - $remain; next; } else { last; } } return $slept; } =head2 rfork_usleep(int) Provides an alarm safe Time::HiRes usleep() wrapper. Beacuse we sleep( +) with in this, ALRM will be issued with in the fork once the sleep c +ycle has completed. This function wraps sleep with in a while() block + and tests to make sure that the seconds requested for the sleep were + slept. This function is only avaliable if Time::HiRes is avaliable otherwise +it will simply return nothing at all. Note, setting $Ext::Fork::no_thr (No Time::HighRes) will disable high +resolution timing. =cut sub rfork_usleep { my $sleep = $_[0]; return if $sleep !~ /^\d+$/; my $sleeper; my $slept = 0; while(1){ if($sleeper < 0 || $sleep <= 0){ last; } elsif(!$sleeper) { $sleeper = $sleep; } my $remain = usleep( abs($sleeper) ); if($remain ne $sleeper && $remain < $sleep){ $slept += $remain; $sleeper = $sleeper - $remain; next; } else { last; } } return $slept; } =head2 rfork_ssleep(int) Preform an rfork_sleep() except rather than using standard sleep() (wi +th interruption handling) use a select() call to sleep. This can be u +seful in environments where sleep() does not behave correctly, and a +select() will block for the desired number of seconds properly. =cut sub rfork_ssleep { $Ext::Fork::select_sleep = 1; my $r = rfork_sleep(@_); $Ext::Fork::select_sleep = 0; return $r; } =head2 rfork_kill_children(SIGNAL) Send all children (if any) this <SIGNAL>. If the <SIGNAL> argument is omitted kill TERM will be used. =cut sub rfork_kill_children { my $sig = $_[0]; if(!$sig){ $sig = 'TERM'; } if($Ext::Fork::POOL->{cidlist}){ kill($sig, keys %{ $Ext::Fork::POOL->{cidlist} }); } } =head2 rfork_list_children(BOOL) Return a list of PID's currently running under this fork. If BOOL is true a hash will be returned rather than a list. =cut sub rfork_list_children { my ($use_hash) = @_; if(!$Ext::Fork::POOL->{cidlist}){ return; } if($use_hash){ return %{ $Ext::Fork::POOL->{cidlist} }; } else { return keys %{ $Ext::Fork::POOL->{cidlist} }; } } =head2 rfork_child_dob(PID) Return the EPOCH Date of Birth for this childs <PID> Returns 0 if no child exists under that PID for this fork. =cut sub rfork_child_dob { my $pid = $_[0]; if($Ext::Fork::POOL->{cidlist}->{$pid}){ return $Ext::Fork::POOL->{cidlist}->{$pid}; } else { return; } } 1;
Re: panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.pm line 380.
by faber (Acolyte) on Dec 19, 2009 at 03:44 UTC
    So I'm still trying to replicate this directly against my module Ext::Fork without success. I think that I may be hitting a bug in one of the XS linked modules I'm using here but haven't found it yet. I'm in the process of putting together a list of all core and non core modules which bootstrap xs and will post it here soon.
Re: panic: attempt to copy freed scalar 802e7e120 to 802e7e708 at Server.pm line 380.
by gmargo (Hermit) on Dec 19, 2009 at 14:50 UTC

    I took a quick look at your Ext::Fork module.

    The only thing that comes to mind at the moment is your SIGCHLD signal handler. I would avoid modifying the cidlist hash within the handler. Just mark the process as done somehow and clean it up outside the handler. Then it can't possibly conflict with the server reading the hash in rfork_list_children(). I would also avoid decrementing the children counter in the handler.

      Ok so I can move the counter out of there, but how do you propose I move the hash management out of there? What other mechanism do you suggest I use to trap child processes which are exiting?

        I would just mark the process done by zeroing the hash value. Then at strategic points in the parent-side code I would "clean up" the list.

        Here is a diff to your code that implements that change. Mind you though, it is completely untested so there may still be gaping holes.

        --- Ext/Fork.pm.00 2009-12-19 06:00:59.000000000 -0800 +++ Ext/Fork.pm 2009-12-20 15:16:22.000000000 -0800 @@ -109,6 +109,7 @@ } while(1){ + rfork_cleanup(); if($Ext::Fork::POOL->{children} < $Ext::Fork::POOL->{max_chil +dren}){ last; } @@ -145,6 +146,7 @@ if($Ext::Fork::POOL->{has_children} && !$Ext::Fork::POOL->{nonblo +cking}){ while(1){ + rfork_cleanup(); last if !$Ext::Fork::POOL->{children}; if($Ext::Fork::has_thr){ rfork_usleep(500); @@ -195,8 +197,7 @@ sub _sigchld { while((my $p = waitpid(-1, WNOHANG)) > 0){ - delete $Ext::Fork::POOL->{cidlist}->{$p}; - $Ext::Fork::POOL->{children} -- if $Ext::Fork::POOL->{childre +n}; + $Ext::Fork::POOL->{cidlist}->{$p} = 0; # mark process as d +one } # self reference @@ -243,6 +244,7 @@ return 1 if $Ext::Fork::POOL->{nonblocking}; while(1){ + rfork_cleanup(); last if !$Ext::Fork::POOL->{children}; if($Ext::Fork::has_thr){ @@ -262,6 +264,7 @@ =cut sub rfork_active_children { + rfork_cleanup(); return ($Ext::Fork::POOL->{children} ? $Ext::Fork::POOL->{childre +n} : 0); } @@ -391,6 +394,7 @@ sub rfork_kill_children { my $sig = $_[0]; + rfork_cleanup(); if(!$sig){ $sig = 'TERM'; } @@ -410,6 +414,7 @@ sub rfork_list_children { my ($use_hash) = @_; + rfork_cleanup(); if(!$Ext::Fork::POOL->{cidlist}){ return; @@ -432,6 +437,7 @@ sub rfork_child_dob { my $pid = $_[0]; + rfork_cleanup(); if($Ext::Fork::POOL->{cidlist}->{$pid}){ return $Ext::Fork::POOL->{cidlist}->{$pid}; } else { @@ -439,4 +445,21 @@ } } +=head2 rfork_cleanup() + +Perform delayed list cleanup. + +=cut + +sub rfork_cleanup { + my @deadpids = + grep { $Ext::Fork::POOL->{cidlist}->{$_} == 0 } + keys %{ $Ext::Fork::POOL->{cidlist} }; + foreach (@deadpids) + { + delete $Ext::Fork::POOL->{cidlist}->{$_}; + $Ext::Fork::POOL->{children} -- if $Ext::Fork::POOL->{childre +n}; + } +} +

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://813410]
Approved by ikegami
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (8)
As of 2014-12-26 04:52 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (165 votes), past polls