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