t/09-load-threads.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($module, $thread_safe_var);
   7 BEGIN {
   8  $module          = 'Scope::Upper';
   9  $thread_safe_var = 'Scope::Upper::SU_THREADSAFE()';
  10 }
  11
  12 sub load_test {
  13  my $res;
  14  {
  15   my $var = 0;
  16   if (defined &Scope::Upper::reap) {
  17    &Scope::Upper::reap(sub { $var *= 2 });
  18    $var = 1;
  19   }
  20   $res = $var;
  21  }
  22  if ($res == 2) {
  23   return 1;
  24  } elsif ($res == 1) {
  25   return 2;
  26  } else {
  27   return $res;
  28  }
  29 }
  30
  31 # Keep the rest of the file untouched
  32
  33 use lib 't/lib';
  34 use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
  35
  36 my $could_not_create_thread = 'Could not create thread';
  37
  38 use Test::Leaner;
  39
  40 sub is_loaded {
  41  my ($affirmative, $desc) = @_;
  42
  43  my $res = load_test();
  44
  45  my $expected;
  46  if ($affirmative) {
  47   $expected = 1;
  48   $desc     = "$desc: module loaded";
  49  } else {
  50   $expected = 0;
  51   $desc     = "$desc: module not loaded";
  52  }
  53
  54  unless (is $res, $expected, $desc) {
  55   $res      = defined $res ? "'$res'" : 'undef';
  56   $expected = "'$expected'";
  57   diag("Test '$desc' failed: got $res, expected $expected");
  58  }
  59
  60  return;
  61 }
  62
  63 BEGIN {
  64  local $@;
  65  my $code = eval "sub { require $module }";
  66  die $@ if $@;
  67  *do_load = $code;
  68 }
  69
  70 is_loaded 0, 'main body, beginning';
  71
  72 # Test serial loadings
  73
  74 SKIP: {
  75  my $thr = spawn(sub {
  76   my $here = "first serial thread";
  77   is_loaded 0, "$here, beginning";
  78
  79   do_load;
  80   is_loaded 1, "$here, after loading";
  81
  82   return;
  83  });
  84
  85  skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
  86
  87  $thr->join;
  88  if (my $err = $thr->error) {
  89   die $err;
  90  }
  91 }
  92
  93 is_loaded 0, 'main body, in between serial loadings';
  94
  95 SKIP: {
  96  my $thr = spawn(sub {
  97   my $here = "second serial thread";
  98   is_loaded 0, "$here, beginning";
  99
 100   do_load;
 101   is_loaded 1, "$here, after loading";
 102
 103   return;
 104  });
 105
 106  skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
 107
 108  $thr->join;
 109  if (my $err = $thr->error) {
 110   die $err;
 111  }
 112 }
 113
 114 is_loaded 0, 'main body, after serial loadings';
 115
 116 # Test nested loadings
 117
 118 SKIP: {
 119  my $parent = spawn(sub {
 120   my $here = 'parent thread';
 121   is_loaded 0, "$here, beginning";
 122
 123   SKIP: {
 124    my $kid = spawn(sub {
 125     my $here = 'child thread';
 126     is_loaded 0, "$here, beginning";
 127
 128     do_load;
 129     is_loaded 1, "$here, after loading";
 130
 131     return;
 132    });
 133
 134    skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
 135
 136    $kid->join;
 137    if (my $err = $kid->error) {
 138     die "in child thread: $err\n";
 139    }
 140   }
 141
 142   is_loaded 0, "$here, after child terminated";
 143
 144   do_load;
 145   is_loaded 1, "$here, after loading";
 146
 147   return;
 148  });
 149
 150  skip "$could_not_create_thread (nested parent)" => (3 + 2)
 151                                                          unless defined $parent;
 152
 153  $parent->join;
 154  if (my $err = $parent->error) {
 155   die $err;
 156  }
 157 }
 158
 159 is_loaded 0, 'main body, after nested loadings';
 160
 161 # Test parallel loadings
 162
 163 use threads;
 164 use threads::shared;
 165
 166 my $sync_points = 7;
 167
 168 my @locks_down = (1) x $sync_points;
 169 my @locks_up   = (0) x $sync_points;
 170 share($_) for @locks_down, @locks_up;
 171
 172 my $default_peers = 2;
 173
 174 sub sync_master {
 175  my ($id, $peers) = @_;
 176
 177  $peers = $default_peers unless defined $peers;
 178
 179  {
 180   lock $locks_down[$id];
 181   $locks_down[$id] = 0;
 182   cond_broadcast $locks_down[$id];
 183  }
 184
 185  LOCK: {
 186   lock $locks_up[$id];
 187   my $timeout = time() + 10;
 188   until ($locks_up[$id] == $peers) {
 189    if (cond_timedwait $locks_up[$id], $timeout) {
 190     last LOCK;
 191    } else {
 192     return 0;
 193    }
 194   }
 195  }
 196
 197  return 1;
 198 }
 199
 200 sub sync_slave {
 201  my ($id) = @_;
 202
 203  {
 204   lock $locks_down[$id];
 205   cond_wait $locks_down[$id] until $locks_down[$id] == 0;
 206  }
 207
 208  {
 209   lock $locks_up[$id];
 210   $locks_up[$id]++;
 211   cond_signal $locks_up[$id];
 212  }
 213
 214  return 1;
 215 }
 216
 217 for my $first_thread_ends_first (0, 1) {
 218  for my $id (0 .. $sync_points - 1) {
 219   {
 220    lock $locks_down[$id];
 221    $locks_down[$id] = 1;
 222   }
 223   {
 224    lock $locks_up[$id];
 225    $locks_up[$id] = 0;
 226   }
 227  }
 228
 229  my $thr1_end = 'finishes first';
 230  my $thr2_end = 'finishes last';
 231
 232  ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
 233                                                 unless $first_thread_ends_first;
 234
 235  SKIP: {
 236   my $thr1 = spawn(sub {
 237    my $here = "first simultaneous thread ($thr1_end)";
 238    sync_slave 0;
 239
 240    is_loaded 0, "$here, beginning";
 241    sync_slave 1;
 242
 243    do_load;
 244    is_loaded 1, "$here, after loading";
 245    sync_slave 2;
 246    sync_slave 3;
 247
 248    sync_slave 4;
 249    is_loaded 1, "$here, still loaded while also loaded in the other thread";
 250    sync_slave 5;
 251
 252    sync_slave 6 unless $first_thread_ends_first;
 253
 254    is_loaded 1, "$here, end";
 255
 256    return 1;
 257   });
 258
 259   skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
 260
 261   my $thr2 = spawn(sub {
 262    my $here = "second simultaneous thread ($thr2_end)";
 263    sync_slave 0;
 264
 265    is_loaded 0, "$here, beginning";
 266    sync_slave 1;
 267
 268    sync_slave 2;
 269    sync_slave 3;
 270    is_loaded 0, "$here, loaded in other thread but not here";
 271
 272    do_load;
 273    is_loaded 1, "$here, after loading";
 274    sync_slave 4;
 275    sync_slave 5;
 276
 277    sync_slave 6 if $first_thread_ends_first;
 278
 279    is_loaded 1, "$here, end";
 280
 281    return 1;
 282   });
 283
 284   sync_master($_) for 0 .. 5;
 285
 286   if (defined $thr2) {
 287    ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
 288
 289    $thr1->join;
 290    if (my $err = $thr1->error) {
 291     die $err;
 292    }
 293
 294    sync_master(6, 1);
 295
 296    $thr2->join;
 297    if (my $err = $thr1->error) {
 298     die $err;
 299    }
 300   } else {
 301    sync_master(6, 1) unless $first_thread_ends_first;
 302
 303    $thr1->join;
 304    if (my $err = $thr1->error) {
 305     die $err;
 306    }
 307
 308    skip "$could_not_create_thread (parallel 2)" => (4 * 1);
 309   }
 310  }
 311
 312  is_loaded 0, 'main body, after simultaneous threads';
 313 }
 314
 315 # Test simple clone
 316
 317 SKIP: {
 318  my $parent = spawn(sub {
 319   my $here = 'simple clone, parent thread';
 320   is_loaded 0, "$here, beginning";
 321
 322   do_load;
 323   is_loaded 1, "$here, after loading";
 324
 325   SKIP: {
 326    my $kid = spawn(sub {
 327     my $here = 'simple clone, child thread';
 328
 329     is_loaded 1, "$here, beginning";
 330
 331     return;
 332    });
 333
 334    skip "$could_not_create_thread (simple clone child)" => 1
 335                                                             unless defined $kid;
 336
 337    $kid->join;
 338    if (my $err = $kid->error) {
 339     die "in child thread: $err\n";
 340    }
 341   }
 342
 343   is_loaded 1, "$here, after child terminated";
 344
 345   return;
 346  });
 347
 348  skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
 349                                                          unless defined $parent;
 350
 351  $parent->join;
 352  if (my $err = $parent->error) {
 353   die $err;
 354  }
 355 }
 356
 357 is_loaded 0, 'main body, after simple clone';
 358
 359 # Test clone outliving its parent
 360
 361 SKIP: {
 362  my $kid_done;
 363  share($kid_done);
 364
 365  my $parent = spawn(sub {
 366   my $here = 'outliving clone, parent thread';
 367   is_loaded 0, "$here, beginning";
 368
 369   do_load;
 370   is_loaded 1, "$here, after loading";
 371
 372   my $kid_tid;
 373
 374   SKIP: {
 375    my $kid = spawn(sub {
 376     my $here = 'outliving clone, child thread';
 377
 378     is_loaded 1, "$here, beginning";
 379
 380     {
 381      lock $kid_done;
 382      cond_wait $kid_done until $kid_done;
 383     }
 384
 385     is_loaded 1, "$here, end";
 386
 387     return 1;
 388    });
 389
 390    if (defined $kid) {
 391     $kid_tid = $kid->tid;
 392    } else {
 393     $kid_tid = 0;
 394     skip "$could_not_create_thread (outliving clone child)" => 2;
 395    }
 396   }
 397
 398   is_loaded 1, "$here, end";
 399
 400   return $kid_tid;
 401  });
 402
 403  skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
 404                                                          unless defined $parent;
 405
 406  my $kid_tid = $parent->join;
 407  if (my $err = $parent->error) {
 408   die $err;
 409  }
 410
 411  if ($kid_tid) {
 412   my $kid = threads->object($kid_tid);
 413   if (defined $kid) {
 414    if ($kid->is_running) {
 415     lock $kid_done;
 416     $kid_done = 1;
 417     cond_signal $kid_done;
 418    }
 419
 420    $kid->join;
 421   }
 422  }
 423 }
 424
 425 is_loaded 0, 'main body, after outliving clone';
 426
 427 do_load;
 428 is_loaded 1, 'main body, loaded at end';
 429
 430 done_testing();