This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rework threads destruct call
authorJerry D. Hedden <jdhedden@cpan.org>
Thu, 20 Apr 2006 13:53:20 +0000 (06:53 -0700)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Fri, 21 Apr 2006 15:55:38 +0000 (15:55 +0000)
From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060420135320.fb30e530d17747c2b054d625b8945d88.ef565d84db.wbe@email.secureserver.net>

p4raw-id: //depot/perl@27933

MANIFEST
ext/threads/t/free.t [new file with mode: 0644]
ext/threads/t/free2.t [new file with mode: 0644]
ext/threads/threads.xs

index 0e71a39..f8ab411 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1129,6 +1129,8 @@ ext/threads/shared/t/wait.t       Test cond_wait and cond_timedwait
 ext/threads/shared/typemap     thread::shared types
 ext/threads/t/basic.t          ithreads
 ext/threads/t/end.t            Test end functions
+ext/threads/t/free.t           Test ithread destruction
+ext/threads/t/free2.t          More ithread destruction tests
 ext/threads/threads.pm         ithreads
 ext/threads/threads.xs         ithreads
 ext/threads/t/join.t           Testing the join function
diff --git a/ext/threads/t/free.t b/ext/threads/t/free.t
new file mode 100644 (file)
index 0000000..bf9e3a7
--- /dev/null
@@ -0,0 +1,184 @@
+use strict;
+use warnings;
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use ExtUtils::testlib;
+
+sub ok {
+    my ($id, $ok, $name) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+BEGIN {
+    $| = 1;
+    print("1..29\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+ok(1, 1, 'Loaded');
+
+### Start of Testing ###
+
+# Tests freeing the Perl interperter for each thread
+# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
+
+my $COUNT;
+share($COUNT);
+my $TEST = 2;
+share($TEST);
+
+sub threading_1 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    if ($tid < 5) {
+        sleep(1);
+        threads->create('threading_1')->detach();
+    }
+
+    threads->yield();
+
+    if ($tid == 1) {
+        sleep(2);
+    } elsif ($tid == 2) {
+        sleep(6);
+    } elsif ($tid == 3) {
+        sleep(3);
+    } elsif ($tid == 4) {
+        sleep(1);
+    } else {
+        sleep(2);
+    }
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create('threading_1')->detach();
+    {
+        lock($COUNT);
+        while ($COUNT < 3) {
+            cond_wait($COUNT);
+        }
+    }
+}
+{
+    {
+        lock($COUNT);
+        while ($COUNT < 5) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 5, "Done - $COUNT threads");
+
+
+sub threading_2 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    if ($tid < 10) {
+        threads->create('threading_2')->detach();
+    }
+
+    threads->yield();
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create('threading_2')->detach();
+    {
+        lock($COUNT);
+        while ($COUNT < 3) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 5, "Done - $COUNT threads");
+
+
+{
+    threads->create(sub { })->join();
+}
+ok($TEST++, 1, 'Join');
+
+
+sub threading_3 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    {
+        threads->create(sub {
+            my $tid = threads->tid();
+            ok($TEST++, $tid, "Thread $tid started");
+
+            threads->yield();
+            sleep(1);
+
+            lock($COUNT);
+            $COUNT++;
+            cond_signal($COUNT);
+
+            ok($TEST++, $tid, "Thread $tid done");
+        })->join();
+    }
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create(sub {
+        threads->create('threading_3')->detach();
+        {
+            lock($COUNT);
+            while ($COUNT < 2) {
+                cond_wait($COUNT);
+            }
+        }
+    })->join();
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 2, "Done - $COUNT threads");
+
+# EOF
diff --git a/ext/threads/t/free2.t b/ext/threads/t/free2.t
new file mode 100644 (file)
index 0000000..d6af217
--- /dev/null
@@ -0,0 +1,287 @@
+use strict;
+use warnings;
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use ExtUtils::testlib;
+
+use threads;
+use threads::shared;
+
+BEGIN {
+    if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) {
+        print("1..0 # Skip: Needs threads::shared 0.92 or later\n");
+        exit(0);
+    }
+
+    $| = 1;
+    print("1..74\n");   ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+ok(1, 'Loaded');
+
+sub ok {
+    my ($ok, $name) = @_;
+
+    lock($TEST);
+    my $id = $TEST++;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+
+### Start of Testing ###
+
+# Tests freeing the Perl interperter for each thread
+# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
+
+my $COUNT;
+share($COUNT);
+my %READY;
+share(%READY);
+
+# Init a thread
+sub th_start {
+    my $tid = threads->tid();
+    ok($tid, "Thread $tid started");
+
+    # Create next thread
+    if ($tid < 17) {
+        my $next = 'th' . ($tid+1);
+        my $th = threads->create($next);
+    } else {
+        # Last thread signals first
+        th_signal(1);
+    }
+    th_wait();
+}
+
+# Thread terminating
+sub th_done {
+    my $tid = threads->tid();
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($tid, "Thread $tid done");
+}
+
+# Wait until signalled by another thread
+sub th_wait
+{
+    my $tid = threads->tid();
+
+    lock(%READY);
+    while (! exists($READY{$tid})) {
+        cond_wait(%READY);
+    }
+    my $other = delete($READY{$tid});
+    ok($tid, "Thread $tid received signal from $other");
+}
+
+# Signal another thread to go
+sub th_signal
+{
+    my $other = shift;
+    my $tid = threads->tid();
+
+    ok($tid, "Thread $tid signalling $other");
+
+    lock(%READY);
+    $READY{$other} = $tid;
+    cond_broadcast(%READY);
+}
+
+#####
+
+sub th1 {
+    th_start();
+
+    threads->detach();
+
+    th_signal(2);
+    th_signal(6);
+    th_signal(10);
+    th_signal(14);
+
+    th_done();
+}
+
+sub th2 {
+    th_start();
+    threads->detach();
+    th_signal(4);
+    th_done();
+}
+
+sub th6 {
+    th_start();
+    threads->detach();
+    th_signal(8);
+    th_done();
+}
+
+sub th10 {
+    th_start();
+    threads->detach();
+    th_signal(12);
+    th_done();
+}
+
+sub th14 {
+    th_start();
+    threads->detach();
+    th_signal(16);
+    th_done();
+}
+
+sub th4 {
+    th_start();
+    threads->detach();
+    th_signal(3);
+    th_done();
+}
+
+sub th8 {
+    th_start();
+    threads->detach();
+    th_signal(7);
+    th_done();
+}
+
+sub th12 {
+    th_start();
+    threads->detach();
+    th_signal(13);
+    th_done();
+}
+
+sub th16 {
+    th_start();
+    threads->detach();
+    th_signal(17);
+    th_done();
+}
+
+sub th3 {
+    my $other = 5;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    threads->yield();
+    sleep(1);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th5 {
+    th_start();
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th7 {
+    my $other = 9;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th9 {
+    th_start();
+    threads->yield();
+    sleep(1);
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th13 {
+    my $other = 11;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    threads->yield();
+    sleep(1);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th11 {
+    th_start();
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th17 {
+    my $other = 15;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th15 {
+    th_start();
+    threads->yield();
+    sleep(1);
+    th_done();
+    return (threads->tid());
+}
+
+
+
+
+
+
+TEST_STARTS_HERE:
+{
+    $COUNT = 0;
+    threads->create('th1');
+    {
+        lock($COUNT);
+        while ($COUNT < 17) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($COUNT == 17, "Done - $COUNT threads");
+
+# EOF
index c63bd90..640bb31 100755 (executable)
@@ -130,45 +130,47 @@ S_ithread_clear(pTHX_ ithread* thread)
  *  free an ithread structure and any attached data if its count == 0
  */
 static void
-S_ithread_destruct (pTHX_ ithread* thread, const char *why)
+S_ithread_destruct (pTHX_ ithread* thread)
 {
+#ifdef WIN32
+        HANDLE handle;
+#endif
+
        MUTEX_LOCK(&thread->mutex);
-       if (!thread->next) {
-           MUTEX_UNLOCK(&thread->mutex);
-           Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
-       }
+
+        /* Thread is still in use */
        if (thread->count != 0) {
                MUTEX_UNLOCK(&thread->mutex);
                return;
        }
-       MUTEX_LOCK(&create_destruct_mutex);
-       /* Remove from circular list of threads */
-       if (thread->next == thread) {
-           /* last one should never get here ? */
-           threads = NULL;
-        }
-       else {
-           thread->next->prev = thread->prev;
-           thread->prev->next = thread->next;
-           if (threads == thread) {
-               threads = thread->next;
-           }
-           thread->next = NULL;
-           thread->prev = NULL;
-       }
 
+       /* Remove from circular list of threads */
+       MUTEX_LOCK(&create_destruct_mutex);
+       thread->next->prev = thread->prev;
+       thread->prev->next = thread->next;
+       thread->next = NULL;
+       thread->prev = NULL;
        MUTEX_UNLOCK(&create_destruct_mutex);
-       /* Thread is now disowned */
 
+       /* Thread is now disowned */
        S_ithread_clear(aTHX_ thread);
-        aTHX = PL_curinterp;
+
+#ifdef WIN32
+        handle = thread->handle;
+        thread->handle = NULL;
+#endif
        MUTEX_UNLOCK(&thread->mutex);
        MUTEX_DESTROY(&thread->mutex);
+
 #ifdef WIN32
-       if (thread->handle)
-           CloseHandle(thread->handle);
-       thread->handle = 0;
+        if (handle)
+            CloseHandle(handle);
 #endif
+
+        /* Call PerlMemShared_free() in the context of the "first" interpreter
+         * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
+         */
+        aTHX = PL_curinterp;
         PerlMemShared_free(thread);
 }
 
@@ -203,7 +205,7 @@ S_ithread_detach(pTHX_ ithread *thread)
     if ((thread->state & PERL_ITHR_FINISHED) &&
         (thread->state & PERL_ITHR_DETACHED)) {
        MUTEX_UNLOCK(&thread->mutex);
-       S_ithread_destruct(aTHX_ thread, "detach");
+       S_ithread_destruct(aTHX_ thread);
     }
     else {
        MUTEX_UNLOCK(&thread->mutex);
@@ -233,7 +235,7 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
            thread->state & PERL_ITHR_JOINED))
        {
             MUTEX_UNLOCK(&thread->mutex);
-            S_ithread_destruct(aTHX_ thread, "no reference");
+            S_ithread_destruct(aTHX_ thread);
        }
        else {
            MUTEX_UNLOCK(&thread->mutex);
@@ -329,7 +331,7 @@ S_ithread_run(void * arg) {
 
        if (thread->state & PERL_ITHR_DETACHED) {
                MUTEX_UNLOCK(&thread->mutex);
-               S_ithread_destruct(aTHX_ thread, "detached finish");
+               S_ithread_destruct(aTHX_ thread);
        } else {
                MUTEX_UNLOCK(&thread->mutex);
        }
@@ -407,10 +409,13 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
            my_exit(1);
        }
        Zero(thread,1,ithread);
+
+        /* Add to threads list */
        thread->next = threads;
        thread->prev = threads->prev;
        threads->prev = thread;
        thread->prev->next = thread;
+
        /* Set count to 1 immediately in case thread exits before
         * we return to caller !
         */
@@ -546,7 +551,7 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
            ) {
          MUTEX_UNLOCK(&create_destruct_mutex);
          sv_2mortal(params);
-         S_ithread_destruct(aTHX_ thread, "create failed");
+         S_ithread_destruct(aTHX_ thread);
 #ifndef WIN32
          if (panic)
            Perl_croak(aTHX_ panic);
@@ -909,9 +914,12 @@ BOOT:
        Zero(thread,1,ithread);
        PL_perl_destruct_level = 2;
        MUTEX_INIT(&thread->mutex);
+
+        /* Head of the threads list */
        threads = thread;
        thread->next = thread;
         thread->prev = thread;
+
        thread->interp = aTHX;
        thread->count  = 1;  /* Immortal. */
        thread->tid = tid_counter++;