In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/bf3e41ff5d42bd65e92e06ce1b1b8f24064a178a?hp=534636494a1e2160ed87b0b7531ddb162be85b6e>
- Log ----------------------------------------------------------------- commit bf3e41ff5d42bd65e92e06ce1b1b8f24064a178a Author: Tony Cook <[email protected]> Date: Thu Feb 28 11:53:19 2019 +1100 (perl #124203) fix a similar problem with DB::lsub commit 500ca7737cc8454aecbe706ae402a2d77cae1b25 Author: Tony Cook <[email protected]> Date: Wed Feb 27 15:29:23 2019 +1100 bump $DB::VERSION for perl5db.pl to 1.55 commit f44c86a807ca7929b8b36eb33ace30035a6d279e Author: Tony Cook <[email protected]> Date: Wed Feb 27 15:28:37 2019 +1100 bump $threads::shared::VERSION to 1.60 commit 609761014c471773184e867d1587daac35036aef Author: Tony Cook <[email protected]> Date: Wed Feb 27 12:01:40 2019 +1100 (perl #124203) avoid a deadlock in DB::sub I don't know how this ever worked. Previously, DB::sub() would hold a lock on $DB::DBGR for it's entire body, including the call to the subroutine being called. This could cause problems in two cases: a) on creation of a new thread, CLONE() is called in the context of the new interpreter before the new thread is created. So you'd have a sequence like: threads->new DB::sub for threads::new (lock $DBGR) call into threads::new which creates a new interpreter Cwd::CLONE() (in the new interpreter) DB::sub for Cwd::CLONE (in the new interpreter) (deadlock trying to lock $DBGR) One workaround I tried for this was to prevent pp_entersub calling DB::sub if we were cloning (by checking PL_ptr_table). This did improve matters, but wasn't needed in the final patch. Note that the recursive lock on $DBGR would have been fine if the new code was executing in the same interpreter, since the locking code simply bumps a reference count if the current interpreter already holds the lock. b) when the called subroutine blocks. For the test case this could happen with the call to $thr->join. There would be a sequence like: (parent) $thr->join (parent) DB::sub for threads::join (lock $DBGR) (parent) call threads::join and block (child) try to call main::sub1 (child) DB::sub for main::sub1 (deadlock trying to lock $DBGR) This isn't limited to threads::join obviously, one thread could be waiting for input, sleeping, or performing a complex calculation. The solution I chose here was the obvious one - don't hold the lock for the actual call. This required some rearrangement of the code and removed some duplication too. commit d22170b0f355b196776681a081a50e5d7a7520cf Author: Tony Cook <[email protected]> Date: Wed Feb 27 12:01:12 2019 +1100 add extra lock tracing to threads::shared This was useful in tracing the cause for the deadlock in #124203. This can be enabled during a build of perl by adding: -Accflags=-DSHARED_TRACE_LOCKS -DDEBUGGING to the Configure command-line. To see the trace at run-time add -DU or -DUv to the perl command-line. The original DEBUG_LOCKS tracing using warn caused extra calls confusing back traces when trying to debug this problem. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 + dist/threads-shared/lib/threads/shared.pm | 4 +- dist/threads-shared/shared.xs | 39 +++++ lib/perl5db.pl | 256 +++++++++++++++--------------- lib/perl5db.t | 39 ++++- lib/perl5db/t/rt-124203 | 7 + lib/perl5db/t/rt-124203b | 13 ++ 7 files changed, 227 insertions(+), 133 deletions(-) create mode 100644 lib/perl5db/t/rt-124203 create mode 100644 lib/perl5db/t/rt-124203b diff --git a/MANIFEST b/MANIFEST index 4466caf308..4cf40a8eec 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4653,6 +4653,8 @@ lib/perl5db/t/proxy-constants Tests for the Perl debugger lib/perl5db/t/rt-104168 Tests for the Perl debugger lib/perl5db/t/rt-120174 Tests for the Perl debugger lib/perl5db/t/rt-121509-restart-after-chdir Tests for the Perl debugger +lib/perl5db/t/rt-124203 Test threads in the Perl debugger +lib/perl5db/t/rt-124203b Test threads in the Perl debugger lib/perl5db/t/rt-61222 Tests for the Perl debugger lib/perl5db/t/rt-66110 Tests for the Perl debugger lib/perl5db/t/source-cmd-test.perldb Tests for the Perl debugger diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index f7e5ff8e73..45ad154979 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -8,7 +8,7 @@ use Config; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.59'; # Please update the pod, too. +our $VERSION = '1.60'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -196,7 +196,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.59 +This document describes threads::shared version 1.60 =head1 SYNOPSIS diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index d0f7d1e070..6cdf094d27 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -115,6 +115,17 @@ * without the prefix (e.g., sv, tmp or obj). */ +/* this is lower overhead than warn() and less likely to interfere + with other parts of perl (like with the debugger.) +*/ +#ifdef SHARED_TRACE_LOCKS +# define TRACE_LOCK(x) DEBUG_U(x) +# define TRACE_LOCKv(x) DEBUG_Uv(x) +#else +# define TRACE_LOCK(x) +# define TRACE_LOCKv(x) +#endif + #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" @@ -211,8 +222,24 @@ recursive_lock_release(pTHX_ recursive_lock_t *lock) if (--lock->locks == 0) { lock->owner = NULL; COND_SIGNAL(&lock->cond); + TRACE_LOCK( + PerlIO_printf(Perl_debug_log, "shared lock released %p for %p at %s:%d\n", + lock, aTHX, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); + } + else { + TRACE_LOCKv( + PerlIO_printf(Perl_debug_log, "shared lock unbump %p for %p at %s:%d\n", + lock, aTHX, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); } } + else { + TRACE_LOCK( + PerlIO_printf(Perl_debug_log, "bad shared lock release %p for %p (owned by %p) at %s:%d\n", + lock, aTHX, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); + } MUTEX_UNLOCK(&lock->mutex); } @@ -224,8 +251,16 @@ recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) assert(aTHX); MUTEX_LOCK(&lock->mutex); if (lock->owner == aTHX) { + TRACE_LOCKv( + PerlIO_printf(Perl_debug_log, "shared lock bump %p (%p) at %s:%d\n", + lock, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); lock->locks++; } else { + TRACE_LOCK( + PerlIO_printf(Perl_debug_log, "shared lock try %p for %p (owned by %p) at %s:%d\n", + lock, aTHX, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); while (lock->owner) { #ifdef DEBUG_LOCKS Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", @@ -233,6 +268,10 @@ recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) #endif COND_WAIT(&lock->cond,&lock->mutex); } + TRACE_LOCK( + PerlIO_printf(Perl_debug_log, "shared lock got %p at %s:%d\n", + lock, CopFILE(PL_curcop), CopLINE(PL_curcop)) + ); lock->locks = 1; lock->owner = aTHX; #ifdef DEBUG_LOCKS diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 39f76f35fe..e8a29da134 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -529,7 +529,7 @@ BEGIN { use vars qw($VERSION $header); # bump to X.XX in blead, only use X.XX_XX in maint -$VERSION = '1.54'; +$VERSION = '1.55'; $header = "perl5db.pl version $VERSION"; @@ -4144,23 +4144,7 @@ sub _print_frame_message { } sub DB::sub { - # lock ourselves under threads - lock($DBGR); - - # Whether or not the autoloader was running, a scalar to put the - # sub's return value in (if needed), and an array to put the sub's - # return value in (if needed). my ( $al, $ret, @ret ) = ""; - if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { - print "creating new thread\n"; - } - - # If the last ten characters are '::AUTOLOAD', note we've traced - # into AUTOLOAD for $sub. - if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { - no strict 'refs'; - $al = " for $$sub" if defined $$sub; - } # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames @@ -4168,40 +4152,49 @@ sub DB::sub { # unwind the same amount when multiple stack frames are unwound. local $stack_depth = $stack_depth + 1; # Protect from non-local exits - # Expand @stack. - $#stack = $stack_depth; + { + # lock ourselves under threads + # While lock() permits recursive locks, there's two cases where it's bad + # that we keep a hold on the lock while we call the sub: + # - during cloning, Package::CLONE might be called in the context of the new + # thread, which will deadlock if we hold the lock across the threads::new call + # - for any function that waits any significant time + # This also deadlocks if the parent thread joins(), since holding the lock + # will prevent any child threads passing this point. + # So release the lock for the function call. + lock($DBGR); - # Save current single-step setting. - $stack[-1] = $single; + # Whether or not the autoloader was running, a scalar to put the + # sub's return value in (if needed), and an array to put the sub's + # return value in (if needed). + if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { + print "creating new thread\n"; + } - # Turn off all flags except single-stepping. - $single &= 1; + # If the last ten characters are '::AUTOLOAD', note we've traced + # into AUTOLOAD for $sub. + if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + no strict 'refs'; + $al = " for $$sub" if defined $$sub; + } - # If we've gotten really deeply recursed, turn on the flag that will - # make us stop with the 'deep recursion' message. - $single |= 4 if $stack_depth == $deep; + # Expand @stack. + $#stack = $stack_depth; - # If frame messages are on ... + # Save current single-step setting. + $stack[-1] = $single; - _print_frame_message($al); - # standard frame entry message + # Turn off all flags except single-stepping. + $single &= 1; - my $print_exit_msg = sub { - # Check for exit trace messages... - if ($frame & 2) - { - if ($frame & 4) # Extended exit message - { - _indent_print_line_info(0, "out "); - print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); - } - else - { - _indent_print_line_info(0, "exited $sub$al\n" ); - } - } - return; - }; + # If we've gotten really deeply recursed, turn on the flag that will + # make us stop with the 'deep recursion' message. + $single |= 4 if $stack_depth == $deep; + + # If frame messages are on ... + + _print_frame_message($al); + } # Determine the sub's return type, and capture appropriately. if (wantarray) { @@ -4209,100 +4202,85 @@ sub DB::sub { # Called in array context. call sub and capture output. # DB::DB will recursively get control again if appropriate; we'll come # back here when the sub is finished. - { - no strict 'refs'; - @ret = &$sub; - } + no strict 'refs'; + @ret = &$sub; + } + elsif ( defined wantarray ) { + no strict 'refs'; + # Save the value if it's wanted at all. + $ret = &$sub; + } + else { + no strict 'refs'; + # Void return, explicitly. + &$sub; + undef $ret; + } + + { + lock($DBGR); # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; - $print_exit_msg->(); + if ($frame & 2) { + if ($frame & 4) { # Extended exit message + _indent_print_line_info(0, "out "); + print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ); + } + else { + _indent_print_line_info(0, "exited $sub$al\n" ); + } + } - # Print the return info if we need to. - if ( $doret eq $stack_depth or $frame & 16 ) { + if (wantarray) { + # Print the return info if we need to. + if ( $doret eq $stack_depth or $frame & 16 ) { - # Turn off output record separator. - local $\ = ''; - my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); + # Turn off output record separator. + local $\ = ''; + my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); - # Indent if we're printing because of $frame tracing. - if ($frame & 16) - { - print {$fh} ' ' x $stack_depth; - } + # Indent if we're printing because of $frame tracing. + if ($frame & 16) + { + print {$fh} ' ' x $stack_depth; + } - # Print the return value. - print {$fh} "list context return from $sub:\n"; - dumpit( $fh, \@ret ); + # Print the return value. + print {$fh} "list context return from $sub:\n"; + dumpit( $fh, \@ret ); - # And don't print it again. - $doret = -2; - } ## end if ($doret eq $stack_depth... + # And don't print it again. + $doret = -2; + } ## end if ($doret eq $stack_depth... # And we have to return the return value now. - @ret; - } ## end if (wantarray) - - # Scalar context. - else { - if ( defined wantarray ) { - no strict 'refs'; - # Save the value if it's wanted at all. - $ret = &$sub; - } + @ret; + } ## end if (wantarray) + # Scalar context. else { - no strict 'refs'; - # Void return, explicitly. - &$sub; - undef $ret; - } - - # Pop the single-step value off the stack. - $single |= $stack[ $stack_depth-- ]; - - # If we're doing exit messages... - $print_exit_msg->(); - - # If we are supposed to show the return value... same as before. - if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { - local $\ = ''; - my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); - print $fh ( ' ' x $stack_depth ) if $frame & 16; - print $fh ( - defined wantarray - ? "scalar context return from $sub: " - : "void context return from $sub\n" - ); - dumpit( $fh, $ret ) if defined wantarray; - $doret = -2; - } ## end if ($doret eq $stack_depth... - - # Return the appropriate scalar value. - $ret; - } ## end else [ if (wantarray) + # If we are supposed to show the return value... same as before. + if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { + local $\ = ''; + my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); + print $fh ( ' ' x $stack_depth ) if $frame & 16; + print $fh ( + defined wantarray + ? "scalar context return from $sub: " + : "void context return from $sub\n" + ); + dumpit( $fh, $ret ) if defined wantarray; + $doret = -2; + } ## end if ($doret eq $stack_depth... + + # Return the appropriate scalar value. + $ret; + } ## end else [ if (wantarray) + } } ## end sub _sub sub lsub : lvalue { - no strict 'refs'; - - # lock ourselves under threads - lock($DBGR); - - # Whether or not the autoloader was running, a scalar to put the - # sub's return value in (if needed), and an array to put the sub's - # return value in (if needed). - my ( $al, $ret, @ret ) = ""; - if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { - print "creating new thread\n"; - } - - # If the last ten characters are C'::AUTOLOAD', note we've traced - # into AUTOLOAD for $sub. - if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { - $al = " for $$sub"; - } - # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames # at once. Localizing the stack pointer means that it will automatically @@ -4320,12 +4298,32 @@ sub lsub : lvalue { # stack for us. local $single = $single & 1; - # If we've gotten really deeply recursed, turn on the flag that will - # make us stop with the 'deep recursion' message. - $single |= 4 if $stack_depth == $deep; + no strict 'refs'; + { + # lock ourselves under threads + lock($DBGR); + + # Whether or not the autoloader was running, a scalar to put the + # sub's return value in (if needed), and an array to put the sub's + # return value in (if needed). + my ( $al, $ret, @ret ) = ""; + if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { + print "creating new thread\n"; + } + + # If the last ten characters are C'::AUTOLOAD', note we've traced + # into AUTOLOAD for $sub. + if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + $al = " for $$sub"; + } - # If frame messages are on ... - _print_frame_message($al); + # If we've gotten really deeply recursed, turn on the flag that will + # make us stop with the 'deep recursion' message. + $single |= 4 if $stack_depth == $deep; + + # If frame messages are on ... + _print_frame_message($al); + } # call the original lvalue sub. &$sub; diff --git a/lib/perl5db.t b/lib/perl5db.t index 3d432ad52e..450f4d067b 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -31,8 +31,6 @@ BEGIN { $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu } -plan(127); - my $rc_filename = '.perldb'; sub rc { @@ -2901,6 +2899,43 @@ SKIP: ); } +SKIP: +{ + $Config{usethreads} + or skip "need threads to test debugging threads", 1; + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'c', + 'q', + ], + prog => '../lib/perl5db/t/rt-124203', + } + ); + + $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran"); + + $wrapper->output_like(qr/Finished/, "[perl #124203] debugger didn't deadlock"); + + $wrapper = DebugWrap->new( + { + cmds => + [ + 'c', + 'q', + ], + prog => '../lib/perl5db/t/rt-124203b', + } + ); + + $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran (lvalue)"); + + $wrapper->output_like(qr/Finished One/, "[perl #124203] debugger didn't deadlock (lvalue)"); +} + +done_testing(); + END { 1 while unlink ($rc_filename, $out_fn); } diff --git a/lib/perl5db/t/rt-124203 b/lib/perl5db/t/rt-124203 new file mode 100644 index 0000000000..85ab7b0b27 --- /dev/null +++ b/lib/perl5db/t/rt-124203 @@ -0,0 +1,7 @@ +use threads; +my $thr = threads->create(\&sub1); +sub sub1 { + print("In the thread\n"); +} +$thr->join; +print "Finished\n"; \ No newline at end of file diff --git a/lib/perl5db/t/rt-124203b b/lib/perl5db/t/rt-124203b new file mode 100644 index 0000000000..a599621566 --- /dev/null +++ b/lib/perl5db/t/rt-124203b @@ -0,0 +1,13 @@ +use threads; +print "PID $$\n"; +my $x; +sub sub1 { + print("In the thread\n"); +} +sub foo:lvalue { + my $thr = threads->create(\&sub1); + $thr->join; + $x; +} +foo() = "One"; +print "Finished $x\n"; -- Perl5 Master Repository
