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
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;
# 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
}
}
{ 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
=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
=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.
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
}
}
+#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
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 */
/* 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: \[$@%]
--- /dev/null
+# 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
+
projects / platform / upstream / perl.git / commitdiff