(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.

1 files changed, 101 insertions, 104 deletions

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 39f76f35fe..745b1173dc 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -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,77 +4202,81 @@ 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 {