develooper Front page | perl.perl5.changes | Postings from March 2019

[perl.git] branch blead updated. v5.29.8-57-gbf3e41ff5d

From:
Tony Cook
Date:
March 7, 2019 23:56
Subject:
[perl.git] branch blead updated. v5.29.8-57-gbf3e41ff5d
Message ID:
E1h22sN-0006vG-HF@git.dc.perl.space
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 <tony@develop-help.com>
Date:   Thu Feb 28 11:53:19 2019 +1100

    (perl #124203) fix a similar problem with DB::lsub

commit 500ca7737cc8454aecbe706ae402a2d77cae1b25
Author: Tony Cook <tony@develop-help.com>
Date:   Wed Feb 27 15:29:23 2019 +1100

    bump $DB::VERSION for perl5db.pl to 1.55

commit f44c86a807ca7929b8b36eb33ace30035a6d279e
Author: Tony Cook <tony@develop-help.com>
Date:   Wed Feb 27 15:28:37 2019 +1100

    bump $threads::shared::VERSION to 1.60

commit 609761014c471773184e867d1587daac35036aef
Author: Tony Cook <tony@develop-help.com>
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 <tony@develop-help.com>
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



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About