in reply to Threaded perl (re: debian bug #203579)
After some digging through the ugly (and at least partially) bad code, I think I know where the error happens, and what you might do to hide this error. There is a programming error in the code where one of the references to a shared variable gets overwritten by a number. In sub cmdloop, replace the line
by$self->{rw} = 1;
${$self->{rw}} = 1;
This makes the code "work" for me in the sense that the segfault disappears with both Perl versions. It then seems to hang in the PRINT command, but that might well be an error in the programming logic. I've pasted my modified code below, maybe somebody sees the deadlock.
#!/usr/bin/perl -w use strict; use threads; sub threadA { for(my $i = 1; $i <= 100; $i++) { warn "Thread A: Print $i"; print FILE "A: $i\n"; } } sub threadB { for(my $i = 1; $i <= 100; $i++) { warn "Thread B: Print $i"; print FILE "B: $i\n"; } } tie *FILE, 'FHShare'; open FILE, '>fhshare.out'; autoflush FILE; my $a = threads->create('threadA'); threadB(); $a->join; close FILE; package FHShare; # A package to share filehandles between threads via tie() use strict; use threads; use threads::shared; use FileHandle; # Subroutine to start thread that accesses filehandle sub start_thread { my $self = shift; $self->cmdloop(); } sub TIEHANDLE { my $class = shift; my $sem : shared; my $cw : shared = 0; my $rw : shared = 0; my @cmd : shared; my @rv : shared; my $err : shared; my $self = { cmd => \@cmd, # Command rv => \@rv, # Return value err => \$err, # Error from calling filehandle method # A semaphore to lock access to send commands to the command # thread: sem => \$sem, # A semaphore for the command thread to notify it that it has # a command waiting: cw => \$cw, # 1 for command waiting # A semaphore for the command thread to notify other threads # that return values are waiting: rw => \$rw }; # 1 for values waiting bless $self, $class; # Create thread attached to this handle threads->create('start_thread', $self)->detach(); return $self; } sub DESTROY { my $self = shift; lock $self->{sem}; ${$self->{cmd}} = (); # Empty list to quit { lock $self->{cw}; ${$self->{cw}} = 1; cond_signal $self->{cw}; } { lock $self->{rw}; while (!${$self->{rw}}) { cond_wait $self->{rw}; } } } # Autoload section -- convert uppercase method names called to # lowercase method names for the underlying filehandle. our $AUTOLOAD; sub AUTOLOAD { my $self = shift; warn "Autoloaded $AUTOLOAD"; my $method = lc($AUTOLOAD); # Convert method to lc. $method =~ s/^.*:://; # Remove prefix. FileHandle->can($method) or die "Error: filehandles have no '$method' method"; my @ret; # Return value { lock $self->{sem}; # Lock access # Send command: warn "$AUTOLOAD: Sent $method(@_)"; @{$self->{cmd}} = ($method, @_); # Tell command thread that it is waiting: { lock $self->{cw}; ${$self->{cw}} = 1; cond_signal $self->{cw}; } # Wait for return values warn "$AUTOLOAD: waiting"; { lock $self->{rw}; while (!${$self->{rw}}) { warn "$AUTOLOAD: waiting for data"; cond_wait $self->{rw}; warn "$AUTOLOAD: done waiting"; } ${$self->{rw}} = 0; # Reset } # Handle errors if (my $err = ${$self->{err}}) { chomp $err; my($filename, $line) = (caller)[2,3]; die "$err at $filename line $line\n"; } @ret = @{$self->{rv}}; # Get return values } return @ret; # Return w/ return vals } # Method for thread that accesses underlying filehandle to loop # through commands sub cmdloop { my $self = shift; warn "Entered command loop"; my $fh = new FileHandle; while (1) { # Wait for and get command { warn "Waiting for command ready"; lock $self->{cw}; while (!${$self->{cw}}) { cond_wait $self->{cw}; } $self->{cw} = 0; # Reset } # Get the method and arguments my @cmd = @{$self->{cmd}} or last; # Quit on empty list my $method = shift @cmd; my @args = @cmd; # Call the method, enqueue the return value(s) my $mcall = "\$fh->$method(\@args)"; warn "sending \$fh->$method(@args)"; @{$self->{rv}} = eval $mcall; #@{$self->{rv}} = $fh->$method(@args); # Record errors ${$self->{err}} = $@; } continue { # Signal that values are waiting { warn "Signaling data available"; lock $self->{rw}; warn "locked 'rw' flag"; warn "'rw' flag is $self->{rw}"; ${$self->{rw}} = 1; warn "'rw' flag is $self->{rw}"; cond_signal $self->{rw}; warn "signalled 'rw' flag"; } } } 1;
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re^2: Threaded perl (re: debian bug #203579)
by BrowserUk (Patriarch) on Feb 26, 2005 at 10:39 UTC |