This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2-arg cond_wait, cond_timedwait, tests
authorMike Pomraning <mjp@pilcrow.madison.wi.us>
Wed, 17 Dec 2003 00:05:58 +0000 (18:05 -0600)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 17 Dec 2003 17:34:05 +0000 (17:34 +0000)
Message-ID: <Pine.LNX.4.58.0312092202040.13494@benevelle.wi.securepipe.com>

p4raw-id: //depot/perl@21921

MANIFEST
ext/threads/shared/shared.pm
ext/threads/shared/shared.xs
ext/threads/shared/t/wait.t [new file with mode: 0644]

index 38ee65e..acf2f20 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -716,6 +716,7 @@ ext/threads/shared/t/no_share.t     Tests for disabled share on variables.
 ext/threads/shared/t/shared_attr.t     Test :shared attribute
 ext/threads/shared/t/sv_refs.t thread shared variables
 ext/threads/shared/t/sv_simple.t       thread shared variables
+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
index abeb1ac..dd6a705 100644 (file)
@@ -6,11 +6,12 @@ use warnings;
 BEGIN {
     require Exporter;
     our @ISA = qw(Exporter);
-    our @EXPORT = qw(share cond_wait cond_broadcast cond_signal);
-    our $VERSION = '0.91';
+    our @EXPORT = qw(share cond_wait cond_timedwait cond_broadcast cond_signal);
+    our $VERSION = '0.92';
 
     if ($threads::threads) {
        *cond_wait = \&cond_wait_enabled;
+       *cond_timedwait = \&cond_timedwait_enabled;
        *cond_signal = \&cond_signal_enabled;
        *cond_broadcast = \&cond_broadcast_enabled;
        require XSLoader;
@@ -24,10 +25,11 @@ BEGIN {
 # saves on average about 4K of memory per thread.
 
         eval <<'EOD';
-sub cond_wait      (\[$@%]) { undef }
-sub cond_signal    (\[$@%]) { undef }
-sub cond_broadcast (\[$@%]) { undef }
-sub share          (\[$@%]) { return $_[0] }
+sub cond_wait      (\[$@%];\[$@%])  { undef }
+sub cond_timedwait (\[$@%]$;\[$@%]) { undef }
+sub cond_signal    (\[$@%])         { undef }
+sub cond_broadcast (\[$@%])         { undef }
+sub share          (\[$@%])         { return $_[0] }
 EOD
     }
 }
@@ -62,9 +64,15 @@ threads::shared - Perl extension for sharing data structures between threads
   { lock(%hash); ...  }
 
   cond_wait($scalar);
+  cond_timedwait($scalar, time() + 30);
   cond_broadcast(@array);
   cond_signal(%hash);
 
+  my $lockvar : shared;
+  # condition var != lock var
+  cond_wait($var, $lockvar);
+  cond_timedwait($var, time()+30, $lockvar);
+
 =head1 DESCRIPTION
 
 By default, variables are private to each thread, and each newly created
@@ -74,7 +82,7 @@ It is used together with the threads module.
 
 =head1 EXPORT
 
-C<share>, C<cond_wait>, C<cond_signal>, C<cond_broadcast>
+C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>
 
 Note that if this module is imported when C<threads> has not yet been
 loaded, then these functions all become no-ops. This makes it possible
@@ -122,6 +130,8 @@ control, see L<Thread::Semaphore>.
 
 =item cond_wait VARIABLE
 
+=item cond_wait CONDVAR, LOCKVAR
+
 The C<cond_wait> function takes a B<locked> variable as a parameter,
 unlocks the variable, and blocks until another thread does a
 C<cond_signal> or C<cond_broadcast> for that same locked variable.
@@ -131,13 +141,47 @@ C<cond_wait>ing on the same variable, all but one will reblock waiting
 to reacquire the lock on the variable. (So if you're only using
 C<cond_wait> for synchronisation, give up the lock as soon as
 possible). The two actions of unlocking the variable and entering the
-blocked wait state are atomic, The two actions of exiting from the
+blocked wait state are atomic, the two actions of exiting from the
 blocked wait state and relocking the variable are not.
 
+In its second form, C<cond_wait> takes a shared, B<unlocked> variable
+followed by a shared, B<locked> variable.  The second variable is
+unlocked and thread execution suspended until another thread signals
+the first variable.
+
 It is important to note that the variable can be notified even if
 no thread C<cond_signal> or C<cond_broadcast> on the variable.
 It is therefore important to check the value of the variable and
-go back to waiting if the requirement is not fulfilled.
+go back to waiting if the requirement is not fulfilled.  For example,
+to pause until a shared counter drops to zero:
+
+    { lock($counter); cond_wait($count) until $counter == 0; }
+
+=item cond_timedwait VARIABLE, ABS_TIMEOUT
+
+=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR
+
+In its two-argument form, C<cond_timedwait> takes a B<locked> variable
+and an absolute timeout as parameters, unlocks the variable, and blocks
+until the timeout is reached or another thread signals the variable.  A
+false value is returned if the timeout is reached, and a true value
+otherwise.  In either case, the variable is re-locked upon return.
+
+Like C<cond_wait>, this function may take a shared, B<locked> variable
+as an additional parameter; in this case the first parameter is an
+B<unlocked> condition variable protected by a distinct lock variable.
+
+Again like C<cond_wait>, waking up and reacquiring the lock are not
+atomic, and you should always check your desired condition after this
+function returns.  Since the timeout is an absolute value, however, it
+does not have to be recalculated with each pass:
+
+    lock($var);
+    my $abs = time() + 15;
+    until ($ok = desired_condition($var)) {
+      last if !cond_timedwait($var, $abs);
+    }
+    # we got it if $ok, otherwise we timed out!
 
 =item cond_signal VARIABLE
 
index dd7724e..911d9ca 100644 (file)
@@ -418,6 +418,77 @@ Perl_sharedsv_share(pTHX_ SV *sv)
     }
 }
 
+#if defined(WIN32) || defined(OS2)
+#  define ABS2RELMILLI(abs)        \
+    do {                                \
+        abs -= (double)time(NULL)       \
+        if (abs > 0) { abs *= 1000; }   \
+        else         { abs  = 0;    }   \
+    } while (0)
+#endif /* WIN32 || OS2 */
+
+bool
+Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
+{
+#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
+    Perl_croak_nocontext("cond_timedwait not supported on this platform");
+#else
+#  ifdef WIN32
+    int got_it = 0;
+
+    ABS2RELMILLI(abs);
+
+    cond->waiters++;
+    MUTEX_UNLOCK(mut);
+    /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
+    switch (WaitForSingleObject(cond->sem, abs)) {
+        case WAIT_OBJECT_0:   got_it = 1; break;
+        case WAIT_TIMEOUT:                break;
+        default:
+            /* WAIT_FAILED? WAIT_ABANDONED? others? */
+            Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
+            break;
+    }
+    MUTEX_LOCK(mut);
+    c->waiters--;
+    return got_it;
+#  else
+#    ifdef OS2
+    int rc, got_it = 0;
+    STRLEN n_a;
+
+    ABS2RELMILLI(abs);
+
+    if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
+        Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
+    MUTEX_UNLOCK(mut);
+    if (CheckOSError(DosWaitEventSem(*cond,abs))
+        && (rc != ERROR_INTERRUPT))
+        croak_with_os2error("panic: cond_timedwait");
+    if (rc == ERROR_INTERRUPT) errno = EINTR;
+    MUTEX_LOCK(mut);
+    return got_it;
+#    else         /* hope you're I_PTHREAD! */
+    struct timespec ts;
+    int got_it = 0;
+
+    ts.tv_sec = (long)abs;
+    abs -= (NV)ts.tv_sec;
+    ts.tv_nsec = (long)(abs * 1000000000.0);
+
+    switch (pthread_cond_timedwait(cond, mut, &ts)) {
+        case 0:         got_it = 1; break;
+        case ETIMEDOUT:             break;
+        default:
+            Perl_croak_nocontext("panic: cond_timedwait");
+            break;
+    }
+    return got_it;
+#    endif /* OS2 */
+#  endif /* WIN32 */
+#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
+}
+
 /* MAGIC (in mg.h sense) hooks */
 
 int
@@ -1040,19 +1111,36 @@ lock_enabled(SV *ref)
        Perl_sharedsv_lock(aTHX_ shared);
 
 void
-cond_wait_enabled(SV *ref)
-       PROTOTYPE: \[$@%]
-       CODE:
+cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
+       PROTOTYPE: \[$@%];\[$@%]
+       PREINIT:
        shared_sv* shared;
+       perl_cond* user_condition;
        int locks;
-       if(!SvROK(ref))
+       int same = 0;
+
+       CODE:
+       if (!ref_lock || ref_lock == ref_cond) same = 1;
+
+       if(!SvROK(ref_cond))
             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
-       ref = SvRV(ref);
-       if(SvROK(ref))
-           ref = SvRV(ref);
-       shared = Perl_sharedsv_find(aTHX_ ref);
+       ref_cond = SvRV(ref_cond);
+       if(SvROK(ref_cond))
+           ref_cond = SvRV(ref_cond);
+       shared = Perl_sharedsv_find(aTHX_ ref_cond);
        if(!shared)
            croak("cond_wait can only be used on shared values");
+
+       user_condition = &shared->user_cond;
+       if (! same) {
+           if (!SvROK(ref_lock))
+               Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
+           ref_lock = SvRV(ref_lock);
+           if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
+           shared = Perl_sharedsv_find(aTHX_ ref_lock);
+           if (!shared)
+               croak("cond_wait lock must be a shared value");
+       }
        if(shared->lock.owner != aTHX)
            croak("You need a lock before you can cond_wait");
        /* Stealing the members of the lock object worries me - NI-S */
@@ -1064,14 +1152,70 @@ cond_wait_enabled(SV *ref)
        /* since we are releasing the lock here we need to tell other
        people that is ok to go ahead and use it */
        COND_SIGNAL(&shared->lock.cond);
-       COND_WAIT(&shared->user_cond, &shared->lock.mutex);
+       COND_WAIT(user_condition, &shared->lock.mutex);
        while(shared->lock.owner != NULL) {
-               COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
-       }       
+           /* OK -- must reacquire the lock */
+           COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
+       }
+       shared->lock.owner = aTHX;
+       shared->lock.locks = locks;
+       MUTEX_UNLOCK(&shared->lock.mutex);
+
+int
+cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
+       PROTOTYPE: \[$@%]$;\[$@%]
+       PREINIT:
+       shared_sv* shared;
+       perl_cond* user_condition;
+       int locks;
+       int same = 0;
+
+       CODE:
+       if (!ref_lock || ref_cond == ref_lock) same = 1;
+
+       if(!SvROK(ref_cond))
+           Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
+       ref_cond = SvRV(ref_cond);
+       if(SvROK(ref_cond))
+           ref_cond = SvRV(ref_cond);
+       shared = Perl_sharedsv_find(aTHX_ ref_cond);
+       if(!shared)
+           croak("cond_timedwait can only be used on shared values");
+    
+       user_condition = &shared->user_cond;
+       if (! same) {
+           if (!SvROK(ref_lock))
+               Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
+           ref_lock = SvRV(ref_lock);
+           if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
+           shared = Perl_sharedsv_find(aTHX_ ref_lock);
+           if (!shared)
+               croak("cond_timedwait lock must be a shared value");
+       }
+       if(shared->lock.owner != aTHX)
+           croak("You need a lock before you can cond_wait");
+
+       MUTEX_LOCK(&shared->lock.mutex);
+       shared->lock.owner = NULL;
+       locks = shared->lock.locks;
+       shared->lock.locks = 0;
+       /* since we are releasing the lock here we need to tell other
+       people that is ok to go ahead and use it */
+       COND_SIGNAL(&shared->lock.cond);
+       RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
+       while (shared->lock.owner != NULL) {
+           /* OK -- must reacquire the lock... */
+           COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
+       }
        shared->lock.owner = aTHX;
        shared->lock.locks = locks;
        MUTEX_UNLOCK(&shared->lock.mutex);
 
+       if (RETVAL == 0)
+            XSRETURN_UNDEF;
+       OUTPUT:
+       RETVAL
+
 void
 cond_signal_enabled(SV *ref)
        PROTOTYPE: \[$@%]
diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t
new file mode 100644 (file)
index 0000000..fe74c68
--- /dev/null
@@ -0,0 +1,267 @@
+# cond_wait and cond_timedwait extended tests
+# adapted from cond.t
+
+use warnings;
+
+BEGIN {
+    chdir 't' if -d 't';
+    push @INC ,'../lib';
+    require Config; import Config;
+    unless ($Config{'useithreads'}) {
+        print "1..0 # Skip: no threads\n";
+        exit 0;
+    }
+}
+$|++;
+print "1..90\n";
+use strict;
+
+use threads;
+use threads::shared;
+use ExtUtils::testlib;
+
+my $Base = 0;
+
+sub ok {
+    my ($offset, $bool, $text) = @_;
+    my $not = '';
+    $not = "not " unless $bool;
+    print "${not}ok " . ($Base + $offset) . " - $text\n";
+}
+
+# - TEST basics
+
+ok(1, defined &cond_wait, "cond_wait() present");
+ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
+    q|cond_wait() prototype '\[$@%];\[$@%]'|);
+ok(3, defined &cond_timedwait, "cond_timedwait() present");
+ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
+    q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|);
+
+$Base += 4;
+
+my @wait_how = (
+   "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
+   "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
+   "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
+);
+
+SYNC_SHARED: {
+  my $test : shared;  # simple|repeat|twain
+  my $cond : shared;
+  my $lock : shared;
+
+  ok(1, 1, "Shared synchronization tests preparation");
+  $Base += 1;
+
+  sub signaller {
+    ok(2,1,"$test: child before lock");
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(3,1,"$test: child obtained lock");
+    if ($test =~ 'twain') {
+      no warnings 'threads';   # lock var != cond var, so disable warnings
+      cond_signal($cond);
+    } else {
+      cond_signal($cond);
+    }
+    ok(4,1,"$test: child signalled condition");
+  }
+
+  # - TEST cond_wait
+  foreach (@wait_how) {
+    $test = "cond_wait [$_]";
+    threads->create(\&cw)->join;
+    $Base += 5;
+  }
+
+  sub cw {
+    ## which lock to obtain in this scope?
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+
+    my $thr = threads->create(\&signaller);
+    for ($test) {
+      cond_wait($cond), last        if    /simple/;
+      cond_wait($cond, $cond), last if    /repeat/;
+      cond_wait($cond, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    $thr->join;
+    ok(5,1, "$test: condition obtained");
+  }
+
+  # - TEST cond_timedwait success
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait [$_]";
+    threads->create(\&ctw, 5)->join;
+    $Base += 5;
+  }
+
+  sub ctw($) {
+    my $to = shift;
+
+    ## which lock to obtain in this scope?
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+
+    my $thr = threads->create(\&signaller);
+    ### N.B.: RACE!  If $timeout is very soon and/or we are unlucky, we
+    ###       might timeout on the cond_timedwait before the signaller
+    ###       thread even attempts lock()ing.
+    ###       Upshot:  $thr->join() never completes, because signaller is
+    ###       stuck attempting to lock the mutex we regained after waiting.
+    my $ok = 0;
+    for ($test) {
+      $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
+      $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
+      $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    print "# back from cond_timedwait; join()ing\n";
+    $thr->join;
+    ok(5,$ok, "$test: condition obtained");
+  }
+
+  # - TEST cond_timedwait timeout
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait pause, timeout [$_]";
+    threads->create(\&ctw_fail, 3)->join;
+    $Base += 2;
+  }
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait instant timeout [$_]";
+    threads->create(\&ctw_fail, -60)->join;
+    $Base += 2;
+  }
+
+  # cond_timedwait timeout (relative timeout)
+  sub ctw_fail {
+    my $to = shift;
+
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+    my $ok;
+    for ($test) {
+      $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
+      $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
+      $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    ok(2,!defined($ok), "$test: timeout");
+  }
+
+} # -- SYNCH_SHARED block
+
+
+# same as above, but with references to lock and cond vars
+
+SYNCH_REFS: {
+  my $test : shared;  # simple|repeat|twain
+  
+  my $true_cond; share($true_cond);
+  my $true_lock; share($true_lock);
+
+  my $cond = \$true_cond;
+  my $lock = \$true_lock;
+
+  ok(1, 1, "Synchronization reference tests preparation");
+  $Base += 1;
+
+  sub signaller2 {
+    ok(2,1,"$test: child before lock");
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(3,1,"$test: child obtained lock");
+    if ($test =~ 'twain') {
+      no warnings 'threads';   # lock var != cond var, so disable warnings
+      cond_signal($cond);
+    } else {
+      cond_signal($cond);
+    }
+    ok(4,1,"$test: child signalled condition");
+  }
+
+  # - TEST cond_wait
+  foreach (@wait_how) {
+    $test = "cond_wait [$_]";
+    threads->create(\&cw2)->join;
+    $Base += 5;
+  }
+
+  sub cw2 {
+    ## which lock to obtain in this scope?
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+
+    my $thr = threads->create(\&signaller2);
+    for ($test) {
+      cond_wait($cond), last        if    /simple/;
+      cond_wait($cond, $cond), last if    /repeat/;
+      cond_wait($cond, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    $thr->join;
+    ok(5,1, "$test: condition obtained");
+  }
+
+  # - TEST cond_timedwait success
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait [$_]";
+    threads->create(\&ctw2, 5)->join;
+    $Base += 5;
+  }
+
+  sub ctw2($) {
+    my $to = shift;
+
+    ## which lock to obtain in this scope?
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+
+    my $thr = threads->create(\&signaller2);
+    ###  N.B.:  RACE!  as above, with ctw()
+    my $ok = 0;
+    for ($test) {
+      $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
+      $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
+      $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    $thr->join;
+    ok(5,$ok, "$test: condition obtained");
+  }
+
+  # - TEST cond_timedwait timeout
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait pause, timeout [$_]";
+    threads->create(\&ctw_fail2, 3)->join;
+    $Base += 2;
+  }
+
+  foreach (@wait_how) {
+    $test = "cond_timedwait instant timeout [$_]";
+    threads->create(\&ctw_fail2, -60)->join;
+    $Base += 2;
+  }
+
+  sub ctw_fail2 {
+    my $to = shift;
+
+    $test =~ /twain/ ? lock($lock) : lock($cond);
+    ok(1,1, "$test: obtained initial lock");
+    my $ok;
+    for ($test) {
+      $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
+      $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
+      $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
+      die "$test: unknown test\n"; 
+    }
+    ok(2,!$ok, "$test: timeout");
+  }
+
+} # -- SYNCH_REFS block
+