t/op/threads.t

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