From: Mike Pomraning Date: Wed, 17 Dec 2003 00:05:58 +0000 (-0600) Subject: 2-arg cond_wait, cond_timedwait, tests X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a0e036c16d5e0642a9302fbca6f6e2831b38dc7c;p=p5sagit%2Fp5-mst-13.2.git 2-arg cond_wait, cond_timedwait, tests Message-ID: p4raw-id: //depot/perl@21921 --- diff --git a/MANIFEST b/MANIFEST index 38ee65e..acf2f20 100644 --- 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 diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index abeb1ac..dd6a705 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -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, C, C, C +C, C, C, C, C Note that if this module is imported when C has not yet been loaded, then these functions all become no-ops. This makes it possible @@ -122,6 +130,8 @@ control, see L. =item cond_wait VARIABLE +=item cond_wait CONDVAR, LOCKVAR + The C function takes a B variable as a parameter, unlocks the variable, and blocks until another thread does a C or C for that same locked variable. @@ -131,13 +141,47 @@ Cing on the same variable, all but one will reblock waiting to reacquire the lock on the variable. (So if you're only using C 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 takes a shared, B variable +followed by a shared, B 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 or C 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 takes a B 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, this function may take a shared, B variable +as an additional parameter; in this case the first parameter is an +B condition variable protected by a distinct lock variable. + +Again like C, 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 diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index dd7724e..911d9ca 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -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 index 0000000..fe74c68 --- /dev/null +++ b/ext/threads/shared/t/wait.t @@ -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 +