t/op/threads.t

   1 #!perl
   2
   3 BEGIN {
   4      chdir 't' if -d 't';
   5      @INC = '../lib';
   6      require './test.pl';
   7      $| = 1;
   8
   9      skip_all_without_config('useithreads');
  10      skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
  11
  12      plan(27);
  13 }
  14
  15 use strict;
  16 use warnings;
  17 use threads;
  18
  19 # test that we don't get:
  20 # Attempt to free unreferenced scalar: SV 0x40173f3c
  21 fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
  22 use threads;
  23 threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
  24 print "ok";
  25 EOI
  26
  27 #PR24660
  28 # test that we don't get:
  29 # Attempt to free unreferenced scalar: SV 0x814e0dc.
  30 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
  31 use threads;
  32 use Scalar::Util;
  33 my $data = "a";
  34 my $obj = \$data;
  35 my $copy = $obj;
  36 Scalar::Util::weaken($copy);
  37 threads->create(sub { 1 })->join for (1..1);
  38 print "ok";
  39 EOI
  40
  41 #PR24663
  42 # test that we don't get:
  43 # panic: magic_killbackrefs.
  44 # Scalars leaked: 3
  45 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
  46 package Foo;
  47 sub new { bless {},shift }
  48 package main;
  49 use threads;
  50 use Scalar::Util qw(weaken);
  51 my $object = Foo->new;
  52 my $ref = $object;
  53 weaken $ref;
  54 threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
  55 print "ok";
  56 EOI
  57
  58 #PR30333 - sort() crash with threads
  59 sub mycmp { length($b) <=> length($a) }
  60
  61 sub do_sort_one_thread {
  62    my $kid = shift;
  63    print "# kid $kid before sort\n";
  64    my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
  65                 'hello', 's', 'thisisalongname', '1', '2', '3',
  66                 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
  67
  68    for my $j (1..99999) {
  69       for my $k (sort mycmp @list) {}
  70    }
  71    print "# kid $kid after sort, sleeping 1\n";
  72    sleep(1);
  73    print "# kid $kid exit\n";
  74 }
  75
  76 sub do_sort_threads {
  77    my $nthreads = shift;
  78    my @kids = ();
  79    for my $i (1..$nthreads) {
  80       my $t = threads->create(\&do_sort_one_thread, $i);
  81       print "# parent $$: continue\n";
  82       push(@kids, $t);
  83    }
  84    for my $t (@kids) {
  85       print "# parent $$: waiting for join\n";
  86       $t->join();
  87       print "# parent $$: thread exited\n";
  88    }
  89 }
  90
  91 do_sort_threads(2);        # crashes
  92 ok(1);
  93
  94 # Change 24643 made the mistake of assuming that CvCONST can only be true on
  95 # XSUBs. Somehow it can also end up on perl subs.
  96 fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
  97 use constant x=>1;
  98 use threads;
  99 $SIG{__WARN__} = sub{};
 100 async sub {};
 101 print "ok";
 102 EOI
 103
 104 # From a test case by Tim Bunce in
 105 # http://www.nntp.perl.org/group/perl.perl5.porters/63123
 106 fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
 107 use threads;
 108 print do 'op/threads_create.pl' || die $@;
 109 EOI
 110
 111
 112 # Scalars leaked: 1
 113 foreach my $BLOCK (qw(CHECK INIT)) {
 114     fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
 115         use threads;
 116         $BLOCK { threads->create(sub {})->join; }
 117         print 'ok';
 118 EOI
 119 }
 120
 121 # Scalars leaked: 1
 122 fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
 123     use threads;
 124     leak($x);
 125     sub leak
 126     {
 127         local $x;
 128         threads->create(sub {})->join();
 129     }
 130     print 'ok';
 131 EOI
 132
 133
 134 # [perl #45053] Memory corruption with heavy module loading in threads
 135 #
 136 # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
 137 # thread-safe - got occasional coredumps or malloc corruption
 138 watchdog(180, "process");
 139 {
 140     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
 141     my @t;
 142     for (1..100) {
 143         my $thr = threads->create( sub { require IO });
 144         last if !defined($thr);      # Probably ran out of memory
 145         push(@t, $thr);
 146     }
 147     $_->join for @t;
 148     ok(1, '[perl #45053]');
 149 }
 150
 151 sub matchit {
 152     is (ref $_[1], "Regexp");
 153     like ($_[0], $_[1]);
 154 }
 155
 156 threads->new(\&matchit, "Pie", qr/pie/i)->join();
 157
 158 # tests in threads don't get counted, so
 159 curr_test(curr_test() + 2);
 160
 161
 162 # the seen_evals field of a regexp was getting zeroed on clone, so
 163 # within a thread it didn't  know that a regex object contained a 'safe'
 164 # code expression, so it later died with 'Eval-group not allowed' when
 165 # you tried to interpolate the object
 166
 167 sub safe_re {
 168     my $re = qr/(?{1})/;        # this is literal, so safe
 169     eval { "a" =~ /$re$re/ };   # interpolating safe values, so safe
 170     ok($@ eq "", 'clone seen-evals');
 171 }
 172 threads->new(\&safe_re)->join();
 173
 174 # tests in threads don't get counted, so
 175 curr_test(curr_test() + 1);
 176
 177 # This used to crash in 5.10.0 [perl #64954]
 178
 179 undef *a;
 180 threads->new(sub {})->join;
 181 pass("undefing a typeglob doesn't cause a crash during cloning");
 182
 183
 184 # Test we don't get:
 185 # panic: del_backref during global destruction.
 186 # when returning a non-closure sub from a thread and subsequently starting
 187 # a new thread.
 188 fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
 189 use threads;
 190 sub foo { return (sub { }); }
 191 my $bar = threads->create(\&foo)->join();
 192 threads->create(sub { })->join();
 193 print "ok";
 194 EOI
 195
 196 # Another, more reliable test for the same del_backref bug:
 197 fresh_perl_is(
 198  <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
 199    use threads;
 200    push @bar, threads->create(sub{sub{}})->join() for 1...10;
 201    print "ok";
 202    EOJ
 203 );
 204
 205 # Simple closure-returning test: At least this case works (though it
 206 # leaks), and we don't want to break it.
 207 fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
 208 use threads;
 209 print create threads sub {
 210  my $x = 'foo';
 211  sub{sub{$x}}
 212 }=>->join->()()
 213  //"undef"
 214 EOJ
 215
 216 # At the point of thread creation, $h{1} is on the temps stack.
 217 # The weak reference $a, however, is visible from the symbol table.
 218 fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
 219     use threads;
 220     %h = (1, 2);
 221     use Scalar::Util 'weaken';
 222     $a = \$h{1};
 223     weaken($a);
 224     delete $h{1} && threads->create(sub {}, shift)->join();
 225     print 'ok';
 226 EOI
 227
 228 # This will fail in "interesting" ways if stashes in clone_params is not
 229 # initialised correctly.
 230 fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
 231     use strict;
 232     use threads;
 233
 234     sub foo::bar;
 235
 236     my %h = (1, *{$::{'foo::'}}{HASH});
 237     *{$::{'foo::'}} = {};
 238
 239     threads->create({}, delete $h{1})->join();
 240
 241     print "end";
 242 EOI
 243
 244 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
 245     use threads;
 246     my %h = (1, []);
 247     use Scalar::Util 'weaken';
 248     my $a = $h{1};
 249     weaken($a);
 250     delete $h{1} && threads->create(sub {}, shift)->join();
 251     print 'ok';
 252 EOI
 253
 254 {
 255     my $got;
 256     sub stuff {
 257         my $a;
 258         if (@_) {
 259             $a = "Leakage";
 260             threads->create(\&stuff)->join();
 261         } else {
 262             is ($a, undef, 'RT #73086 - clone used to clone active pads');
 263         }
 264     }
 265
 266     stuff(1);
 267
 268     curr_test(curr_test() + 1);
 269 }
 270
 271 {
 272     my $got;
 273     sub more_stuff {
 274         my $a;
 275         $::b = \$a;
 276         if (@_) {
 277             $a = "More leakage";
 278             threads->create(\&more_stuff)->join();
 279         } else {
 280             is ($a, undef, 'Just special casing lexicals in ?{ ... }');
 281         }
 282     }
 283
 284     more_stuff(1);
 285
 286     curr_test(curr_test() + 1);
 287 }
 288
 289 # Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
 290 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
 291 use strict;
 292 use warnings;
 293
 294 use threads;
 295
 296 {
 297     package My::Obj;
 298     use Scalar::Util 'weaken';
 299
 300     my %reg;
 301
 302     sub new
 303     {
 304         # Create object with ID = 1
 305         my $class = shift;
 306         my $id = 1;
 307         my $obj = bless(\do{ my $scalar = $id; }, $class);
 308
 309         # Save weak copy of object for reference during cloning
 310         weaken($reg{$id} = $obj);
 311
 312         # Return object
 313         return $obj;
 314     }
 315
 316     # Return the internal ID of the object
 317     sub id
 318     {
 319         my $obj = shift;
 320         return $$obj;
 321     }
 322
 323     # During cloning 'look' at the object
 324     sub CLONE {
 325         foreach my $id (keys(%reg)) {
 326             # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant.
 327             my $obj = $reg{$id};
 328         }
 329     }
 330 }
 331
 332 # Create object in 'main' thread
 333 my $obj = My::Obj->new();
 334 my $id = $obj->id();
 335 die "\$id is '$id'" unless $id == 1;
 336
 337 # Access object in thread
 338 threads->create(
 339     sub {
 340         print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
 341     }
 342 )->join();
 343
 344 EOI
 345
 346 # make sure peephole optimiser doesn't recurse heavily.
 347 # (We run this inside a thread to get a small stack)
 348
 349 {
 350     # lots of constructs that have o->op_other etc
 351     my $code = <<'EOF';
 352         $r = $x || $y;
 353         $x ||= $y;
 354         $r = $x // $y;
 355         $x //= $y;
 356         $r = $x && $y;
 357         $x &&= $y;
 358         $r = $x ? $y : $z;
 359         @a = map $x+1, @a;
 360         @a = grep $x+1, @a;
 361         $r = /$x/../$y/;
 362
 363         # this one will fail since we removed tail recursion optimisation
 364         # with f11ca51e41e8
 365         #while (1) { $x = 0 };
 366
 367         while (0) { $x = 0 };
 368         for ($x=0; $y; $z=0) { $r = 0 };
 369         for (1) { $x = 0 };
 370         { $x = 0 };
 371         $x =~ s/a/$x + 1/e;
 372 EOF
 373     $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 1000);
 374     my $res = threads->create(sub { eval $code})->join;
 375     is($res, 5, "avoid peephole recursion");
 376 }
 377
 378
 379 # [perl #78494] Pipes shared between threads block when closed
 380 {
 381   my $perl = which_perl;
 382   $perl = qq'"$perl"' if $perl =~ /\s/;
 383   open(my $OUT, "|$perl") || die("ERROR: $!");
 384   threads->create(sub { })->join;
 385   ok(1, "Pipes shared between threads do not block when closed");
 386 }
 387
 388 # [perl #105208] Typeglob clones should not be cloned again during a join
 389 {
 390   threads->create(sub { sub { $::hypogamma = 3 } })->join->();
 391   is $::hypogamma, 3, 'globs cloned and joined are not recloned';
 392 }
 393
 394 fresh_perl_is(
 395   'use threads;' .
 396   'async { delete $::{INC}; eval q"my $foo : bar" } ->join; print "ok\n";',
 397   "ok",
 398    {},
 399   'no crash when deleting $::{INC} in thread'
 400 );
 401
 402 # EOF