1use strict;
2use warnings;
3
4BEGIN {
5    use Config;
6    if (! $Config{'useithreads'}) {
7        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
8        exit(0);
9    }
10    if ($^O eq 'hpux' && $Config{osvers} <= 10.20) {
11        print("1..0 # SKIP Broken under HP-UX 10.20\n");
12        exit(0);
13    }
14
15    # http://lists.alioth.debian.org/pipermail/perl-maintainers/2011-June/002285.html
16    # There _is_ TLS support on m68k, but this stress test is overwhelming
17    # for the hardware
18    if ($^O eq 'linux' && $Config{archname} =~ /^m68k/) {
19        print("1..0 # Skip: m68k doesn't have enough oomph for these stress tests\n");
20        exit(0);
21    }
22}
23
24use ExtUtils::testlib;
25
26BEGIN {
27    $| = 1;
28    print("1..1\n");   ### Number of tests that will be run ###
29};
30
31use threads;
32use threads::shared;
33
34### Start of Testing ###
35
36#####
37#
38# Launches a bunch of threads which are then
39# restricted to finishing in numerical order
40#
41#####
42{
43    my $cnt = 50;
44
45    # Depending on hardware and compiler options, the time for a busy loop can
46    # by a factor of (at least) 40, so one size doesn't fit all.
47    # For a fixed iteration count, on a particularly slow machine the timeout
48    # can fire before all threads have had a realistic chance to complete, but
49    # dropping the iteration count will cause fast machines to finish each
50    # thread too quickly.
51    # Fastest machine I tested can loop 20,000,000 times a second, slowest
52    # 500,000
53
54    my $busycount;
55    {
56        my $tries = 1e4;
57        # Try to align to the start of a second:
58        my $want = time + 1;
59        while (time < $want && --$tries) {
60            my $sum;
61            for (0..1e4) {
62                ++$sum;
63            }
64        }
65
66        if ($tries) {
67            $tries = 1e4;
68            ++$want;
69
70            while (time < $want && --$tries) {
71                my $sum;
72                for (0..1e4) {
73                    ++$sum;
74                }
75            }
76
77            # This should be about 0.025s
78            $busycount = (1e4 - $tries) * 250;
79        } else {
80            # Fall back to the old default if everything fails
81            $busycount = 500000;
82        }
83        print "# Looping for $busycount iterations should take about 0.025s\n";
84    }
85
86    my $TIMEOUT = 60;
87
88    my $mutex = 1;
89    share($mutex);
90
91    my $warning;
92    $SIG{__WARN__} = sub { $warning = shift; };
93
94    my @threads;
95
96    for (reverse(1..$cnt)) {
97        $threads[$_] = threads->create(sub {
98                            my $tnum = shift;
99                            my $timeout = time() + $TIMEOUT;
100                            threads->yield();
101
102                            # Randomize the amount of work the thread does
103                            my $sum;
104                            for (0..($busycount+int(rand($busycount)))) {
105                                $sum++
106                            }
107
108                            # Lock the mutex
109                            lock($mutex);
110
111                            # Wait for my turn to finish
112                            while ($mutex != $tnum) {
113                                if (! cond_timedwait($mutex, $timeout)) {
114                                    if ($mutex == $tnum) {
115                                        return ('timed out - cond_broadcast not received');
116                                    } else {
117                                        return ('timed out');
118                                    }
119                                }
120                            }
121
122                            # Finish up
123                            $mutex++;
124                            cond_broadcast($mutex);
125                            return ('okay');
126                      }, $_);
127
128        # Handle thread creation failures
129        if ($warning) {
130            my $printit = 1;
131            if ($warning =~ /returned 11/) {
132                $warning = "Thread creation failed due to 'No more processes'\n";
133                $printit = (! $ENV{'PERL_CORE'});
134            } elsif ($warning =~ /returned 12/) {
135                $warning = "Thread creation failed due to 'No more memory'\n";
136                $printit = (! $ENV{'PERL_CORE'});
137            }
138            print(STDERR "# Warning: $warning") if ($printit);
139            lock($mutex);
140            $mutex = $_ + 1;
141            last;
142        }
143    }
144
145    # Gather thread results
146    my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0, 0);
147    for (1..$cnt) {
148        if (! $threads[$_]) {
149            $failures++;
150        } else {
151            my $rc = $threads[$_]->join();
152            if (! $rc) {
153                $failures++;
154            } elsif ($rc =~ /^timed out/) {
155                $timeouts++;
156            } elsif ($rc eq 'okay') {
157                $okay++;
158            } else {
159                $unknown++;
160                print(STDERR "# Unknown error: $rc\n");
161            }
162        }
163    }
164
165    if ($failures) {
166        my $only = $cnt - $failures;
167        print(STDERR "# Warning: Intended to use $cnt threads, but could only muster $only\n");
168        $cnt -= $failures;
169    }
170
171    if ($unknown || (($okay + $timeouts) != $cnt)) {
172        print("not ok 1\n");
173        my $too_few = $cnt - ($okay + $timeouts + $unknown);
174        print(STDERR "# Test failed:\n");
175        print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
176        print(STDERR "#\t$unknown unknown errors\n")           if $unknown;
177        print(STDERR "#\t$timeouts threads timed out\n")       if $timeouts;
178
179    } elsif ($timeouts) {
180        # Frequently fails under MSWin32 due to deadlocking bug in Windows
181        # hence test is TODO under MSWin32
182        #   http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
183        #   http://support.microsoft.com/kb/175332
184        if ($^O eq 'MSWin32') {
185            print("not ok 1 # TODO - not reliable under MSWin32\n")
186        } else {
187            print("not ok 1\n");
188            print(STDERR "# Test failed: $timeouts threads timed out\n");
189        }
190
191    } else {
192        print("ok 1\n");
193    }
194}
195
196exit(0);
197
198# EOF
199