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