diff options
Diffstat (limited to 'ext/threads')
| -rw-r--r-- | ext/threads/shared/Changes | 8 | ||||
| -rw-r--r-- | ext/threads/shared/README | 2 | ||||
| -rw-r--r-- | ext/threads/shared/shared.pm | 6 | ||||
| -rw-r--r-- | ext/threads/shared/shared.xs | 43 | ||||
| -rw-r--r-- | ext/threads/shared/t/blessed.t | 2 | ||||
| -rw-r--r-- | ext/threads/shared/t/waithires.t | 344 |
6 files changed, 392 insertions, 13 deletions
diff --git a/ext/threads/shared/Changes b/ext/threads/shared/Changes index ed09cef71c..a28a0685b5 100644 --- a/ext/threads/shared/Changes +++ b/ext/threads/shared/Changes @@ -1,6 +1,12 @@ Revision history for Perl extension threads::shared. -1.07 - Mon Feb 5 15:41:50 EST 2007 +1.08 Wed Mar 14 12:40:57 EDT 2007 + - Sub-second resolution for cont_timedwait under WIN32 + (courtesy of Dean Arnold) + - Fix compiler warnings + - Upgraded ppport.h to Devel::PPPort 3.11 + +1.07 Wed Feb 7 10:44:22 EST 2007 - POD tweaks per Wolfgang Laun 1.06 Wed Dec 20 14:01:57 EST 2006 diff --git a/ext/threads/shared/README b/ext/threads/shared/README index fa305530bc..b351b01cc4 100644 --- a/ext/threads/shared/README +++ b/ext/threads/shared/README @@ -1,4 +1,4 @@ -threads::shared version 1.07 +threads::shared version 1.08 ============================ This module needs Perl 5.8.0 or later compiled with USEITHREADS. diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index ca4b74eb87..59768a0cf6 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.07'; +our $VERSION = '1.08'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -73,7 +73,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.07 +This document describes threads::shared version 1.08 =head1 SYNOPSIS @@ -368,7 +368,7 @@ L<threads::shared> Discussion Forum on CPAN: L<http://www.cpanforum.com/dist/threads-shared> Annotated POD for L<threads::shared>: -L<http://annocpan.org/~JDHEDDEN/threads-shared-1.07/shared.pm> +L<http://annocpan.org/~JDHEDDEN/threads-shared-1.08/shared.pm> L<threads>, L<perlthrtut> diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index dcc2c97c7c..0072baa451 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -412,7 +412,6 @@ Perl_sharedsv_find(pTHX_ SV *sv) void Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) { - dTHXc; MAGIC *mg = 0; /* If we are asked for any private ops we need a thread */ @@ -551,14 +550,43 @@ Perl_sharedsv_share(pTHX_ SV *sv) } -#if defined(WIN32) || defined(OS2) +#ifdef WIN32 +/* Number of milliseconds from 1/1/1601 to 1/1/1970 */ +#define EPOCH_BIAS 11644473600000. + +/* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */ +STATIC DWORD +S_abs_2_rel_milli(double abs) +{ + double rel; + + /* Get current time (in units of 100 nanoseconds since 1/1/1601) */ + union { + FILETIME ft; + unsigned __int64 i64; + } now; + + GetSystemTimeAsFileTime(&now.ft); + + /* Relative time in milliseconds */ + rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS); + + if (rel <= 0.0) { + return (0); + } + return (DWORD)rel; +} + +#else +# if defined(OS2) # define ABS2RELMILLI(abs) \ do { \ abs -= (double)time(NULL); \ if (abs > 0) { abs *= 1000; } \ else { abs = 0; } \ } while (0) -#endif /* WIN32 || OS2 */ +# endif /* OS2 */ +#endif /* WIN32 */ /* Do OS-specific condition timed wait */ @@ -571,12 +599,10 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) # 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, (DWORD)abs)) { + switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) { case WAIT_OBJECT_0: got_it = 1; break; case WAIT_TIMEOUT: break; default: @@ -708,7 +734,7 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) SV *sobj = Perl_sharedsv_find(aTHX_ obj); if (sobj) { SHARED_CONTEXT; - SvUPGRADE(ssv, SVt_RV); + (void)SvUPGRADE(ssv, SVt_RV); sv_setsv_nomg(ssv, &PL_sv_undef); SvRV_set(ssv, SvREFCNT_inc(sobj)); @@ -1253,6 +1279,9 @@ NEXTKEY(SV *obj, SV *oldkey) char* key = NULL; I32 len = 0; HE* entry; + + PERL_UNUSED_VAR(oldkey); + ENTER_LOCK; SHARED_CONTEXT; entry = hv_iternext((HV*) sobj); diff --git a/ext/threads/shared/t/blessed.t b/ext/threads/shared/t/blessed.t index 9938ad0259..4408c36ce2 100644 --- a/ext/threads/shared/t/blessed.t +++ b/ext/threads/shared/t/blessed.t @@ -99,7 +99,7 @@ ok(23, ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); ok(24, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); ok(25, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); -threads->create(sub { +threads->new(sub { # Rebless objects bless $hobj, 'oof'; bless $aobj, 'rab'; diff --git a/ext/threads/shared/t/waithires.t b/ext/threads/shared/t/waithires.t new file mode 100644 index 0000000000..b39fa4579f --- /dev/null +++ b/ext/threads/shared/t/waithires.t @@ -0,0 +1,344 @@ +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); + } + eval { + require Time::HiRes; + import Time::HiRes qw(time); + }; + if ($@) { + print("1..0 # Skip: Time::HiRes not available.\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +my $Base = 0; +sub ok { + my ($id, $ok, $name) = @_; + $id += $Base; + + # 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..63\n"); ### Number of tests that will be run ### +}; + +use threads; +use threads::shared; + +ok(1, 1, 'Loaded'); +$Base++; + +### Start of Testing ### + +# subsecond cond_timedwait extended tests adapted from wait.t + +# The two skips later on in these tests refer to this quote from the +# pod/perl583delta.pod: +# +# =head1 Platform Specific Problems +# +# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9 +# and HP-UX 10.20 due to bugs in their threading implementations. +# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html +# and consider upgrading their glibc. + +sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in + # stock RH9 glibc/NPTL) or from our own errors, we run tests + # in separately forked and alarmed processes. + +*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i) +? sub (&$$) { my $code = shift; goto &$code; } +: sub (&$$) { + my ($code, $expected, $patience) = @_; + my ($test_num, $pid); + local *CHLD; + + my $bump = $expected; + + $patience ||= 60; + + unless (defined($pid = open(CHLD, "-|"))) { + die "fork: $!\n"; + } + if (! $pid) { # Child -- run the test + $patience ||= 60; + alarm $patience; + &$code; + exit; + } + + while (<CHLD>) { + $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/; + #print "#forko: ($expected, $1) $_"; + print; + } + + close(CHLD); + + while ($expected--) { + $test_num++; + print "not ok $test_num - child status $?\n"; + } + + $Base += $bump; + +}; + +# - TEST basics + +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_timedwait success + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait [$_]"; + threads->create(\&ctw, 0.05)->join; + $Base += 6; + } + }, 6*@wait_how, 5); + + sub ctw($) { + my $to = shift; + my $thr; + + { # -- begin lock scope; which lock to obtain? + $test =~ /twain/ ? lock($lock) : lock($cond); + ok(1,1, "$test: obtained initial lock"); + + $thr = threads->create(\&signaller); + 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"; + } + ok(5,$ok, "$test: condition obtained"); + } # -- end lock scope + + $thr->join; + ok(6,1, "$test: join completed"); + } + + # - TEST cond_timedwait timeout + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait pause, timeout [$_]"; + threads->create(\&ctw_fail, 0.3)->join; + $Base += 2; + } + }, 2*@wait_how, 5); + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait instant timeout [$_]"; + threads->create(\&ctw_fail, -0.60)->join; + $Base += 2; + } + }, 2*@wait_how, 5); + + # cond_timedwait timeout (relative timeout) + sub ctw_fail { + my $to = shift; + if ($^O eq "hpux" && $Config{osvers} <= 10.20) { + # The lock obtaining would pass, but the wait will not. + ok(1,1, "$test: obtained initial lock"); + ok(2,0, "# SKIP see perl583delta"); + } else { + $test =~ /twain/ ? lock($lock) : lock($cond); + ok(1,1, "$test: obtained initial lock"); + my $ok; + my $delta = time(); + 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"; + } + $delta = time() - $delta; + if (($to < 0) || ($^O eq 'os2')) { + ok(2, ! defined($ok), "$test: timeout"); + } else { + # This is a bit problematic, as scheduling and compute latencies + # can inject delays in our computation. For now, assume -10/+20% + # is reasonable + if (! ok(2, ! defined($ok) && + ($delta > (0.9 * $to)) && + ($delta < (1.2 * $to)), + "$test: timeout")) + { + print(STDERR "# Timeout: specified=$to actual=$delta secs.\n"); + } + } + } + } + +} # -- 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_timedwait success + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait [$_]"; + threads->create(\&ctw2, 0.05)->join; + $Base += 6; + } + }, 6*@wait_how, 5); + + sub ctw2($) { + my $to = shift; + my $thr; + + { # -- begin lock scope; which lock to obtain? + $test =~ /twain/ ? lock($lock) : lock($cond); + ok(1,1, "$test: obtained initial lock"); + + $thr = threads->create(\&signaller2); + 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"; + } + ok(5,$ok, "$test: condition obtained"); + } # -- end lock scope + + $thr->join; + ok(6,1, "$test: join completed"); + } + + # - TEST cond_timedwait timeout + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait pause, timeout [$_]"; + threads->create(\&ctw_fail2, 0.3)->join; + $Base += 2; + } + }, 2*@wait_how, 5); + + forko( sub { + foreach (@wait_how) { + $test = "cond_timedwait instant timeout [$_]"; + threads->create(\&ctw_fail2, -0.60)->join; + $Base += 2; + } + }, 2*@wait_how, 5); + + sub ctw_fail2 { + my $to = shift; + + if ($^O eq "hpux" && $Config{osvers} <= 10.20) { + # The lock obtaining would pass, but the wait will not. + ok(1,1, "$test: obtained initial lock"); + ok(2,0, "# SKIP see perl583delta"); + } else { + $test =~ /twain/ ? lock($lock) : lock($cond); + ok(1,1, "$test: obtained initial lock"); + my $ok; + my $delta = time(); + 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"; + } + $delta = time() - $delta; + if (($to < 0) || ($^O eq 'os2')) { + ok(2,!$ok, "$test: timeout"); + } else { + # This is a bit problematic, as scheduling and compute latencies + # can inject delays in our computation. For now, assume -10/+20% + # is reasonable + if (! ok(2, ! $ok && + ($delta > (0.9 * $to)) && + ($delta < (1.2 * $to)), + "$test: timeout")) + { + print(STDERR "# Timeout: specified=$to actual=$delta secs.\n"); + } + } + } + } + +} # -- SYNCH_REFS block + +# EOF |