ext/threads/shared/t/cond.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 my $Base = 0;
  19 sub ok {
  20     my ($id, $ok, $name) = @_;
  21     $id += $Base;
  22
  23     # You have to do it this way or VMS will get confused.
  24     if ($ok) {
  25         print("ok $id - $name\n");
  26     } else {
  27         print("not ok $id - $name\n");
  28         printf("# Failed test at line %d\n", (caller)[2]);
  29     }
  30
  31     return ($ok);
  32 }
  33
  34 BEGIN {
  35     $| = 1;
  36     print("1..82\n");   ### Number of tests that will be run ###
  37 };
  38
  39 use threads;
  40 use threads::shared;
  41 ok(1, 1, 'Loaded');
  42 $Base++;
  43
  44 ### Start of Testing ###
  45
  46 # test locking
  47 {
  48     my $lock : shared;
  49     my $tr;
  50
  51     # test that a subthread can't lock until parent thread has unlocked
  52
  53     {
  54         lock($lock);
  55         ok(1, 1, "set first lock");
  56         $tr = async {
  57             lock($lock);
  58             ok(3, 1, "set lock in subthread");
  59         };
  60         threads->yield;
  61         ok(2, 1, "still got lock");
  62     }
  63     $tr->join;
  64
  65     $Base += 3;
  66
  67     # ditto with ref to thread
  68
  69     {
  70         my $lockref = \$lock;
  71         lock($lockref);
  72         ok(1,1,"set first lockref");
  73         $tr = async {
  74             lock($lockref);
  75             ok(3,1,"set lockref in subthread");
  76         };
  77         threads->yield;
  78         ok(2,1,"still got lockref");
  79     }
  80     $tr->join;
  81
  82     $Base += 3;
  83
  84     # make sure recursive locks unlock at the right place
  85     {
  86         lock($lock);
  87         ok(1,1,"set first recursive lock");
  88         lock($lock);
  89         threads->yield;
  90         {
  91             lock($lock);
  92             threads->yield;
  93         }
  94         $tr = async {
  95             lock($lock);
  96             ok(3,1,"set recursive lock in subthread");
  97         };
  98         {
  99             lock($lock);
 100             threads->yield;
 101             {
 102                 lock($lock);
 103                 threads->yield;
 104                 lock($lock);
 105                 threads->yield;
 106             }
 107         }
 108         ok(2,1,"still got recursive lock");
 109     }
 110     $tr->join;
 111
 112     $Base += 3;
 113
 114     # Make sure a lock factory gives out fresh locks each time
 115     # for both attribute and run-time shares
 116
 117     sub lock_factory1 { my $lock : shared; return \$lock; }
 118     sub lock_factory2 { my $lock; share($lock); return \$lock; }
 119
 120     my (@locks1, @locks2);
 121     push @locks1, lock_factory1() for 1..2;
 122     push @locks1, lock_factory2() for 1..2;
 123     push @locks2, lock_factory1() for 1..2;
 124     push @locks2, lock_factory2() for 1..2;
 125
 126     ok(1,1,"lock factory: locking all locks");
 127     lock $locks1[0];
 128     lock $locks1[1];
 129     lock $locks1[2];
 130     lock $locks1[3];
 131     ok(2,1,"lock factory: locked all locks");
 132     $tr = async {
 133         ok(3,1,"lock factory: child: locking all locks");
 134         lock $locks2[0];
 135         lock $locks2[1];
 136         lock $locks2[2];
 137         lock $locks2[3];
 138         ok(4,1,"lock factory: child: locked all locks");
 139     };
 140     $tr->join;
 141
 142     $Base += 4;
 143 }
 144
 145
 146 # test cond_signal()
 147 {
 148     my $lock : shared;
 149
 150     sub foo {
 151         lock($lock);
 152         ok(1,1,"cond_signal: created first lock");
 153         my $tr2 = threads->create(\&bar);
 154         cond_wait($lock);
 155         $tr2->join();
 156         ok(5,1,"cond_signal: joined");
 157     }
 158
 159     sub bar {
 160         ok(2,1,"cond_signal: child before lock");
 161         lock($lock);
 162         ok(3,1,"cond_signal: child locked");
 163         cond_signal($lock);
 164         ok(4,1,"cond_signal: signalled");
 165     }
 166
 167     my $tr  = threads->create(\&foo);
 168     $tr->join();
 169
 170     $Base += 5;
 171
 172     # ditto, but with lockrefs
 173
 174     my $lockref = \$lock;
 175     sub foo2 {
 176         lock($lockref);
 177         ok(1,1,"cond_signal: ref: created first lock");
 178         my $tr2 = threads->create(\&bar2);
 179         cond_wait($lockref);
 180         $tr2->join();
 181         ok(5,1,"cond_signal: ref: joined");
 182     }
 183
 184     sub bar2 {
 185         ok(2,1,"cond_signal: ref: child before lock");
 186         lock($lockref);
 187         ok(3,1,"cond_signal: ref: child locked");
 188         cond_signal($lockref);
 189         ok(4,1,"cond_signal: ref: signalled");
 190     }
 191
 192     $tr  = threads->create(\&foo2);
 193     $tr->join();
 194
 195     $Base += 5;
 196 }
 197
 198
 199 # test cond_broadcast()
 200 {
 201     my $counter : shared = 0;
 202
 203     # broad(N) forks off broad(N-1) and goes into a wait, in such a way
 204     # that it's guaranteed to reach the wait before its child enters the
 205     # locked region. When N reaches 0, the child instead does a
 206     # cond_broadcast to wake all its ancestors.
 207
 208     sub broad {
 209         my $n = shift;
 210         my $th;
 211         {
 212             lock($counter);
 213             if ($n > 0) {
 214                 $counter++;
 215                 $th = threads->create(\&broad, $n-1);
 216                 cond_wait($counter);
 217                 $counter += 10;
 218             }
 219             else {
 220                 ok(1, $counter == 3, "cond_broadcast: all three waiting");
 221                 cond_broadcast($counter);
 222             }
 223         }
 224         $th->join if $th;
 225     }
 226
 227     threads->create(\&broad, 3)->join;
 228     ok(2, $counter == 33, "cond_broadcast: all three threads woken");
 229
 230     $Base += 2;
 231
 232
 233     # ditto, but with refs and shared()
 234
 235     my $counter2 = 0;
 236     share($counter2);
 237     my $r = \$counter2;
 238
 239     sub broad2 {
 240         my $n = shift;
 241         my $th;
 242         {
 243             lock($r);
 244             if ($n > 0) {
 245                 $$r++;
 246                 $th = threads->create(\&broad2, $n-1);
 247                 cond_wait($r);
 248                 $$r += 10;
 249             }
 250             else {
 251                 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
 252                 cond_broadcast($r);
 253             }
 254         }
 255         $th->join if $th;
 256     }
 257
 258     threads->create(\&broad2, 3)->join;;
 259     ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
 260
 261     $Base += 2;
 262 }
 263
 264
 265 # test warnings;
 266 {
 267     my $warncount = 0;
 268     local $SIG{__WARN__} = sub { $warncount++ };
 269
 270     my $lock : shared;
 271
 272     cond_signal($lock);
 273     ok(1, $warncount == 1, 'get warning on cond_signal');
 274     cond_broadcast($lock);
 275     ok(2, $warncount == 2, 'get warning on cond_broadcast');
 276     no warnings 'threads';
 277     cond_signal($lock);
 278     ok(3, $warncount == 2, 'get no warning on cond_signal');
 279     cond_broadcast($lock);
 280     ok(4, $warncount == 2, 'get no warning on cond_broadcast');
 281
 282     $Base += 4;
 283 }
 284
 285
 286 # Stress test
 287 {
 288     my $cnt = 50;
 289
 290     my $mutex = 1;
 291     share($mutex);
 292
 293     my @threads;
 294     for (1..$cnt) {
 295         $threads[$_] = threads->create(sub {
 296                             my $arg = shift;
 297                             my $result = 0;
 298                             for (0..1000000) {
 299                                 $result++;
 300                             }
 301                             lock($mutex);
 302                             while ($mutex != $arg) {
 303                                 cond_wait($mutex);
 304                             }
 305                             $mutex++;
 306                             cond_broadcast($mutex);
 307                             return $result;
 308                       }, $_);
 309     }
 310
 311     for (1..$cnt) {
 312         my $result = $threads[$_]->join();
 313         ok($_, defined($result) && ("$result" eq '1000001'), "stress test - iter $_");
 314     }
 315
 316     $Base += $cnt;
 317 }
 318
 319 # EOF