develooper Front page | perl.perl5.porters | Postings from October 2003

[perl #24363] Thread::Semaphore wake one, trydown, tests, doc [PATCH]

From:
perlbug-followup
Date:
October 30, 2003 21:08
Subject:
[perl #24363] Thread::Semaphore wake one, trydown, tests, doc [PATCH]
Message ID:
rt-24363-66734.18.857613704491@rt.perl.org
# New Ticket Created by  mjp-perl-ZYsBlwkHGFY@pilcrow.madison.wi.us 
# Please include the string:  [perl #24363]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=24363 >


This is a bug report for perl from mjp@box.securepipe.com,
generated with the help of perlbug 1.34 running under perl v5.8.2.


-----------------------------------------------------------------
[Please enter your report here]

The following patch to Thread::Semaphore adds three things:

- trydown() method (and corresponding pod update)
  Without a trylock() function, or perhaps 'lock THING NONBLOCKING', some
  sort of easy, nonblocking synch operation is needed, IMHO (ala IPC_NOWAIT,
  pthread_mutex_trylock(), etc.).

  trydown has predictable return values, backward-compatible with down()'s
  (undocumented) return of the decreased sem count when successful.

- wake one behavior

  Currently, up() cond_broadcasts, awakening all blocked downers if the sem
  value is positive.  Worst case, all needlessly wake up and go right back
  to sleep (if attempted decrements exceed the sem value).  In the more
  common case of a binary sem with N blocked threads, N-1 will likely resume
  cond_wait()ing after the lucky first of them locks the sem.

  The patched behavior is to cond_signal after any change that leaves the
  sem > 0 (up, down or trydown).  Worst case, one cond_signal is lost b/c
  there aren't any downers to hear it anyway.

- test cases
  Semaphore.t seemed a bit meager.  :-)

======[BEGIN PATCH]==============================================
--- perl-5.8.2-RC1/lib/Thread/Semaphore.pm.orig	Wed Oct 29 15:53:14 2003
+++ perl-5.8.2-RC1/lib/Thread/Semaphore.pm	Wed Oct 29 15:58:47 2003
@@ -21,6 +21,12 @@
     $s->down($down_value);
     $s->up($up_value);
 
+    # Non-blocking down
+    if ($s->trydown) {
+      # Guarded section
+      $s->up;
+    }
+
 =head1 DESCRIPTION
 
 Semaphores provide a mechanism to regulate access to resources. Semaphores,
@@ -57,6 +63,14 @@
 word "pak", which means "capture" -- the semaphore operations were
 named by the late Dijkstra, who was Dutch).
 
+=item trydown
+
+=item trydown NUMBER
+
+C<trydown> behaves like the C<down> method, except that it returns undef rather
+than blocking if the semaphore's count would drop below zero.  Otherwise,
+trydown returns a true value.
+
 =item up
 
 =item up NUMBER
@@ -84,14 +98,24 @@
     lock($$s);
     my $inc = @_ ? shift : 1;
     cond_wait $$s until $$s >= $inc;
-    $$s -= $inc;
+    ($$s -= $inc) > 0 and cond_signal $$s;
+    $$s;
+}
+
+sub trydown {
+    my $s = shift;
+    lock($$s);
+    my $inc = @_ ? shift : 1;
+    return unless $$s >= $inc;
+    ($$s -= $inc) > 0 and cond_signal $$s;
+    $$s || '0 but true';
 }
 
 sub up {
     my $s = shift;
     lock($$s);
     my $inc = @_ ? shift : 1;
-    ($$s += $inc) > 0 and cond_broadcast $$s;
+    ($$s += $inc) > 0 and cond_signal $$s;
 }
 
 1;
--- perl-5.8.2-RC1/lib/Thread/Semaphore.t.orig	Wed Oct 29 16:10:35 2003
+++ perl-5.8.2-RC1/lib/Thread/Semaphore.t	Wed Oct 29 21:30:43 2003
@@ -10,8 +10,74 @@
     }
 }
 
-print "1..1\n";
+print "1..25\n";
 use threads;
 use Thread::Semaphore;
-print "ok 1\n";
+use strict;
 
+my $test : shared = 1;
+my $s;
+
+$| = 1;
+
+sub snooze($) { threads->yield; sleep $_[0]; }
+sub thread_count() { scalar(my @thr = threads->list); }
+
+sub ok($) {
+  lock($test);
+  my $ok = $_[0] ? "ok" : "not ok";
+  print "$ok $test\n";
+  $test++;
+}
+
+ok(1);
+
+$s = new Thread::Semaphore;
+
+ok(defined $s);                    # new
+ok($$s == 1);                      # (default value)
+
+$s->up for 1 .. 3;
+ok($$s == 4);                      # up
+
+$s->up(10);
+ok($$s == 14);                     # up NUMBER
+
+$s->down;
+ok($$s == 13);                     # down
+
+$s->down(13);
+ok($$s == 0);                      # down NUMBER
+
+ok(!defined($s->trydown));         # trydown (would block)
+$s->up;
+ok(!defined($s->trydown(5)));      # trydown NUMBER (would block)
+
+ok($s->trydown);                   # trydown ('0 but true');
+
+$s->up for 1 .. 3;
+ok($s->trydown(3));                # trydown NUMBER ('0 but true');
+
+async { $s->up(4); }->join;
+ok($$s == 4);                      # sem is shared;
+
+async { $s->down(5); ok(1); } for 1 .. 10;
+async {
+  my $tid = threads->tid;
+  for my $thr (threads->list) {
+    $thr->join unless $thr->tid == $tid;
+  }
+}
+
+snooze 2;
+ok(thread_count() == 11);          # 10 downing, 1 joining
+$s->up(21);
+
+snooze 2;
+ok(thread_count() == 6);           # 5 downing, 1 joining
+$s->up(25);
+
+snooze 2;
+ok(thread_count() == 1);           # 1 unjoined, prob. finished
+
+$_->join for threads->list;
======[END PATCH]================================================

- 

[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=library
    severity=medium
---
Site configuration information for perl v5.8.2:

Configured by mjp at Wed Oct 29 16:00:59 CST 2003.

Summary of my perl5 (revision 5.0 version 8 subversion 2) configuration:
  Platform:
    osname=linux, osvers=2.4.20-19.7, archname=i686-linux-thread-multi
    uname='linux box.wi.securepipe.com 2.4.20-19.7 #1 tue jul 15 13:44:14 edt 2003 i686 unknown '
    config_args='-de'
    hint=previous, useposix=true, d_sigaction=define
    usethreads=define use5005threads=undef useithreads=define usemultiplicity=define
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm',
    optimize='-O2',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -fno-strict-aliasing -I/usr/local/include -I/usr/include/gdbm -D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm'
    ccversion='', gccversion='2.96 20000731 (Red Hat Linux 7.3 2.96-113)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -lndbm -lgdbm -ldl -lm -lcrypt -lutil -lpthread -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
    libc=/lib/libc-2.2.5.so, so=so, useshrplib=true, libperl=libperl.so
    gnulibc_version='2.2.5'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic -Wl,-rpath,/usr/local/lib/perl5/5.8.1/i686-linux-thread-multi/CORE'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    RC1

---
@INC for perl v5.8.2:
    /home/mjp/tmp/perl-5.8.2-RC1/lib
    /usr/local/lib/perl5/5.8.1/i686-linux-thread-multi
    /usr/local/lib/perl5/5.8.1
    /usr/local/lib/perl5/site_perl/5.8.1/i686-linux-thread-multi
    /usr/local/lib/perl5/site_perl/5.8.1
    /usr/local/lib/perl5/site_perl/5.8.1
    .

---
Environment for perl v5.8.2:
    HOME=/home/mjp
    LANG=en_US.iso885915
    LANGUAGE (unset)
    LD_LIBRARY_PATH=/home/mjp/tmp/perl-5.8.2-RC1
    LOGDIR (unset)
    PATH=/home/mjp/opt/bin:/usr/local/bin:/bin:/usr/bin:/usr/X11R6/bin:/home/mjp/bin
    PERL5LIB=/home/mjp/tmp/perl-5.8.2-RC1/lib:
    PERL_BADLANG (unset)
    SHELL=/bin/bash




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