This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b159823c1534bc2312823ff4a0e3a76e8ea50de8
[perl5.git] / 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(25);
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 {
139     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
140     my @t;
141     for (1..100) {
142         my $thr = threads->create( sub { require IO });
143         last if !defined($thr);      # Probably ran out of memory
144         push(@t, $thr);
145     }
146     $_->join for @t;
147     ok(1, '[perl #45053]');
148 }
149
150 sub matchit {
151     is (ref $_[1], "Regexp");
152     like ($_[0], $_[1]);
153 }
154
155 threads->new(\&matchit, "Pie", qr/pie/i)->join();
156
157 # tests in threads don't get counted, so
158 curr_test(curr_test() + 2);
159
160
161 # the seen_evals field of a regexp was getting zeroed on clone, so
162 # within a thread it didn't  know that a regex object contained a 'safe'
163 # re_eval expression, so it later died with 'Eval-group not allowed' when
164 # you tried to interpolate the object
165
166 sub safe_re {
167     my $re = qr/(?{1})/;        # this is literal, so safe
168     eval { "a" =~ /$re$re/ };   # interpolating safe values, so safe
169     ok($@ eq "", 'clone seen-evals');
170 }
171 threads->new(\&safe_re)->join();
172
173 # tests in threads don't get counted, so
174 curr_test(curr_test() + 1);
175
176 # This used to crash in 5.10.0 [perl #64954]
177
178 undef *a;
179 threads->new(sub {})->join;
180 pass("undefing a typeglob doesn't cause a crash during cloning");
181
182
183 # Test we don't get:
184 # panic: del_backref during global destruction.
185 # when returning a non-closure sub from a thread and subsequently starting
186 # a new thread.
187 fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
188 use threads;
189 sub foo { return (sub { }); }
190 my $bar = threads->create(\&foo)->join();
191 threads->create(sub { })->join();
192 print "ok";
193 EOI
194
195 # Another, more reliable test for the same del_backref bug:
196 fresh_perl_is(
197  <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
198    use threads;
199    push @bar, threads->create(sub{sub{}})->join() for 1...10;
200    print "ok";
201    EOJ
202 );
203
204 # Simple closure-returning test: At least this case works (though it
205 # leaks), and we don't want to break it.
206 fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
207 use threads;
208 print create threads sub {
209  my $x = 'foo';
210  sub{sub{$x}}
211 }=>->join->()()
212  //"undef"
213 EOJ
214
215 # At the point of thread creation, $h{1} is on the temps stack.
216 # The weak reference $a, however, is visible from the symbol table.
217 fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
218     use threads;
219     %h = (1, 2);
220     use Scalar::Util 'weaken';
221     $a = \$h{1};
222     weaken($a);
223     delete $h{1} && threads->create(sub {}, shift)->join();
224     print 'ok';
225 EOI
226
227 # This will fail in "interesting" ways if stashes in clone_params is not
228 # initialised correctly.
229 fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
230     use strict;
231     use threads;
232
233     sub foo::bar;
234
235     my %h = (1, *{$::{'foo::'}}{HASH});
236     *{$::{'foo::'}} = {};
237
238     threads->create({}, delete $h{1})->join();
239
240     print "end";
241 EOI
242
243 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
244     use threads;
245     my %h = (1, []);
246     use Scalar::Util 'weaken';
247     my $a = $h{1};
248     weaken($a);
249     delete $h{1} && threads->create(sub {}, shift)->join();
250     print 'ok';
251 EOI
252
253 {
254     my $got;
255     sub stuff {
256         my $a;
257         if (@_) {
258             $a = "Leakage";
259             threads->create(\&stuff)->join();
260         } else {
261             is ($a, undef, 'RT #73086 - clone used to clone active pads');
262         }
263     }
264
265     stuff(1);
266
267     curr_test(curr_test() + 1);
268 }
269
270 {
271     my $got;
272     sub more_stuff {
273         my $a;
274         $::b = \$a;
275         if (@_) {
276             $a = "More leakage";
277             threads->create(\&more_stuff)->join();
278         } else {
279             is ($a, undef, 'Just special casing lexicals in ?{ ... }');
280         }
281     }
282
283     more_stuff(1);
284
285     curr_test(curr_test() + 1);
286 }
287
288 # Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
289 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
290 use strict;
291 use warnings;
292
293 use threads;
294
295 {
296     package My::Obj;
297     use Scalar::Util 'weaken';
298
299     my %reg;
300
301     sub new
302     {
303         # Create object with ID = 1
304         my $class = shift;
305         my $id = 1;
306         my $obj = bless(\do{ my $scalar = $id; }, $class);
307
308         # Save weak copy of object for reference during cloning
309         weaken($reg{$id} = $obj);
310
311         # Return object
312         return $obj;
313     }
314
315     # Return the internal ID of the object
316     sub id
317     {
318         my $obj = shift;
319         return $$obj;
320     }
321
322     # During cloning 'look' at the object
323     sub CLONE {
324         foreach my $id (keys(%reg)) {
325             # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant.
326             my $obj = $reg{$id};
327         }
328     }
329 }
330
331 # Create object in 'main' thread
332 my $obj = My::Obj->new();
333 my $id = $obj->id();
334 die "\$id is '$id'" unless $id == 1;
335
336 # Access object in thread
337 threads->create(
338     sub {
339         print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
340     }
341 )->join();
342
343 EOI
344
345 # make sure peephole optimiser doesn't recurse heavily.
346 # (We run this inside a thread to get a small stack)
347
348 {
349     # lots of constructs that have o->op_other etc
350     my $code = <<'EOF';
351         $r = $x || $y;
352         $x ||= $y;
353         $r = $x // $y;
354         $x //= $y;
355         $r = $x && $y;
356         $x &&= $y;
357         $r = $x ? $y : $z;
358         $r = $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x"
359            : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : "y";
360         @a = map $x+1, @a;
361         @a = grep $x+1, @a;
362         $r = /$x/../$y/;
363         while (1) { $x = 0 };
364         while (0) { $x = 0 };
365         for ($x=0; $y; $z=0) { $r = 0 };
366         for (1) { $x = 0 };
367         { $x = 0 };
368         $x =~ s/a/$x + 1/e;
369 EOF
370     $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 1000);
371     my $res = threads->create(sub { eval $code})->join;
372     is($res, 5, "avoid peephole recursion");
373 }
374
375
376 # [perl #78494] Pipes shared between threads block when closed
377 watchdog 10;
378 {
379   my $perl = which_perl;
380   $perl = qq'"$perl"' if $perl =~ /\s/;
381   open(my $OUT, "|$perl") || die("ERROR: $!");
382   threads->create(sub { })->join;
383   ok(1, "Pipes shared between threads do not block when closed");
384 }
385
386 # EOF