2 # Copyright (C) 2001-2005, The Perl Foundation.
7 use lib qw( . lib ../lib ../../lib );
13 t/pmc/threads.t - Threads
17 % prove t/pmc/threads.t
21 Tests running threads. All tests skipped unless running on known-good
26 my %platforms = map { $_ => 1 } qw/
39 if ( $^O eq "cygwin" ) {
40 my @uname = split / /, qx'uname -v';
42 if ( $uname[0] eq "2004-09-04" ) {
43 plan skip_all => "This cygwin version is known to fail the thread tests";
47 if ( $platforms{$^O} ) {
51 plan skip_all => "No threading yet or test not enabled for '$^O'";
53 # plan skip_all => "Needs COPY for argument passing";
56 pasm_output_is( <<'CODE', <<'OUTPUT', "interp identity" );
74 # XXX FIXME rework tests since we don't really have thread types?
77 skip 'busted on win32' => 2 if $^O eq 'MSWin32';
79 pir_output_is( <<'CODE', <<'OUTPUT', "thread type 1" );
84 threadfunc = global "foo"
85 thread = new .ParrotThread
86 thread.'run_clone'(threadfunc)
99 # check if vars are fresh
102 # print I5 # not done because registers aren't guaranteed to be
103 # initialized to anything in particular
105 set I3, 0 # no retval
106 returncc # ret and be done with thread
108 # output from threads could be reversed
114 pir_output_is( <<'CODE', <<'OUTPUT', "thread type 1 -- repeated" );
124 .local pmc threadfunc
127 threadfunc = global "foo"
128 thread = new .ParrotThread
129 thread.'run_clone'(threadfunc)
142 # check if vars are fresh
145 # print I5 # not done because registers aren't guaranteed to be
146 # initialized to anything in particular
148 set I3, 0 # no retval
149 returncc # ret and be done with thread
151 # output from threads could be reversed
160 pir_output_is( <<'CODE', <<'OUTPUT', "thread type 2" );
170 threadsub = global "foo"
171 thread = new .ParrotThread
172 thread.'run_clone'(threadsub, P6)
173 sleep 1 # to let the thread run
184 passed = 'hello from'
186 # print I5 # not done because register initialization is not guaranteed
203 pir_output_is( <<'CODE', <<'OUTPUT', 'thread - kill' );
207 bounds 1 # assert slow core -S and -g are fine too
208 threadsub = global "foo"
209 thread = new .ParrotThread
214 thread.'run_clone'(threadsub)
216 sleep 1 # to let the thread run
236 pir_output_is( <<'CODE', <<'OUTPUT', "join, get retval" );
238 .const int MAX = 1000
241 Adder = global '_add'
242 kid = new ParrotThread
249 kid.'run_clone'(Adder, Adder, from, to)
252 result = kid.'join'()
255 # sum = n * (n + 1)/2
288 skip( "detatch broken on $^O", 1 ) if ( $^O =~ /MSWin32/ );
289 pir_output_like( <<'CODE', <<'OUTPUT', "detach" );
295 queue = new .TQueue # flag for when the thread is done
296 thread = new .ParrotThread
297 thread.'run_clone'(foo, queue)
302 if $I0 == 0 goto wait
314 /(done\nthread\n)|(thread\ndone\n)/
318 pir_output_is( <<'CODE', <<'OUTPUT', "share a PMC" );
323 to_share = new Integer
324 .local pmc shared_ref
325 shared_ref = new SharedRef, to_share
328 thread = new ParrotThread
329 thread.'run_clone'(foo, shared_ref)
331 sleep 0.1 # to let the thread run
341 .param pmc shared_ref
354 pir_output_is( <<'CODE', <<'OUT', "multi-threaded" );
370 thread = new ParrotThread
373 thread.'run_clone'(foo, queue)
385 if $I0 == 0 goto done
391 print "done thread\n"
402 pir_output_is( <<'CODE', <<'OUT', "sub name lookup in new thread" );
404 $P0 = find_global 'Foo', 'foo'
414 $P0 = new ParrotThread
415 .local pmc thread_main
416 thread_main = find_global 'thread_main'
417 $P0.'run_clone'(thread_main)
428 print "not reached\n"
435 pir_output_is( <<'CODE', <<'OUTPUT', "CLONE_CODE only" );
437 .namespace [ 'Test2' ]
442 .namespace [ 'Test3' ]
447 .namespace [ 'main' ]
449 .include 'errors.pasm'
455 test3 = find_global 'Test3', 'test3'
458 errorsoff .PARROT_ERRORS_GLOBALS_FLAG
459 test4 = global 'test4'
460 if null test4 goto okay
466 .include 'cloneflags.pasm'
471 test2 = find_global 'Test2', 'test2'
475 store_global 'test4', test4
478 thread = new ParrotThread
479 .local pmc thread_func
480 thread_func = global 'thread_func'
481 $I0 = .PARROT_CLONE_CODE
482 thread.'run'($I0, thread_func, test2)
494 pir_output_is( <<'CODE', <<'OUTPUT', "CLONE_CODE | CLONE_GLOBALS" );
501 .param pmc shortlabel
502 if what == expect goto okay
518 .sub thread_test_func
519 $P0 = find_global 'Bar', 'alpha'
520 'is'($P0, 1, 'Bar::alpha == 1', 'alpha')
522 sleep 0.1 # give enough time that the main thread might modify
523 # any shared Foo::beta dn cause phantom errors
524 $P0 = find_global 'beta'
525 'is'($P0, 2, 'Foo::beta == 2 [accessed locally]', 'beta1')
527 $P0 = find_global 'beta'
528 'is'($P0, 5, 'Foo::beta == 5 [accessed locally after assignment]', 'beta2')
529 $P0 = find_global 'Foo', 'beta'
530 'is'($P0, 5, 'Foo::beta == 5 [after assign; absolute]', 'beta3')
533 .namespace [ 'main' ]
538 store_global 'Bar', 'alpha', $P0
541 store_global 'Foo', 'beta', $P0
544 .include 'cloneflags.pasm'
549 thread = new ParrotThread
550 .local pmc _thread_func
551 _thread_func = find_global 'Foo', 'thread_test_func'
552 $I0 = .PARROT_CLONE_CODE
553 bor $I0, $I0, .PARROT_CLONE_GLOBALS
555 thread.'run'($I0, _thread_func)
556 $P0 = find_global 'Foo', 'beta'
576 pir_output_is( <<'CODE', <<'OUTPUT', "CLONE_CODE | CLONE_CLASSES; superclass not built-in" );
580 print "called Foo's foometh\n"
584 print "called Foo's barmeth\n"
590 print "called Bar's barmeth\n"
593 .sub __get_string :method
597 .namespace [ 'main' ]
601 addattribute $P1, 'foo1'
602 addattribute $P1, 'foo2'
603 $P2 = subclass $P1, 'Bar'
604 addattribute $P2, 'bar1'
607 .sub thread_test_func
608 $I0 = find_type 'Bar'
614 $I0 = isa $P0, 'Integer'
628 .include 'cloneflags.pasm'
633 thread = new ParrotThread
634 .local pmc _thread_func
635 _thread_func = find_global 'main', 'thread_test_func'
636 $I0 = .PARROT_CLONE_CODE
637 bor $I0, $I0, .PARROT_CLONE_CLASSES
639 thread.'run'($I0, _thread_func)
661 pir_output_is( <<'CODE', <<'OUTPUT', "CLONE_CODE | CLONE_CLASSES; superclass built-in" );
665 print "called Foo's foometh\n"
669 print "called Foo's barmeth\n"
675 print "called Bar's barmeth\n"
678 .sub __get_string :method
682 .namespace [ 'main' ]
685 $P0 = getclass .Integer
686 $P1 = subclass $P0, 'Foo'
687 addattribute $P1, 'foo1'
688 addattribute $P1, 'foo2'
689 $P2 = subclass $P1, 'Bar'
690 addattribute $P2, 'bar1'
693 .sub thread_test_func
694 $I0 = find_type 'Bar'
700 $I0 = isa $P0, 'Integer'
714 .include 'cloneflags.pasm'
719 thread = new ParrotThread
720 .local pmc _thread_func
721 _thread_func = find_global 'main', 'thread_test_func'
722 $I0 = .PARROT_CLONE_CODE
723 bor $I0, $I0, .PARROT_CLONE_CLASSES
725 thread.'run'($I0, _thread_func)
747 pir_output_is( <<'CODE', <<'OUTPUT', "CLONE_CODE | CLONE_GLOBALS| CLONE_HLL" );
752 store_global 'x', $P0
755 .include 'interpinfo.pasm'
757 $P0 = find_global 'x'
758 if $P0 == 42 goto okay1
762 $P1 = get_root_namespace
766 if $P0 == 43 goto okay2
774 .include 'cloneflags.pasm'
779 setup = get_root_namespace
780 setup = setup['test']
782 setup = setup['setup']
787 thread = new ParrotThread
788 flags = .PARROT_CLONE_CODE
789 bor flags, flags, .PARROT_CLONE_GLOBALS
790 bor flags, flags, .PARROT_CLONE_HLL
792 thread.'run'(flags, test)
806 pir_output_unlike( <<'CODE', qr/not/, "globals + constant table subs issue" );
809 .include 'interpinfo.pasm'
814 number = global 'test_num'
815 if what == expect goto okay
824 $P0 = interpinfo .INTERPINFO_CURRENT_CONT
827 if $I0 == 0 goto done
831 $P0 = $P0.'continuation'()
845 store_global 'foo', $P0
850 $P1 = find_global 'Foo', 'foo'
857 store_global 'foo', $P0
862 $P0 = global '_check_sanity'
864 $P0 = find_global 'Foo', '_check_sanity'
877 $P0 = global '_check_value'
879 $P0 = find_global 'Foo', '_check_value'
884 .const .Sub c_setup = 'setup'
885 .const .Sub c_sanity = 'check_sanity'
886 .const .Sub c_mutate = 'mutate'
887 .const .Sub c_value = 'check_value'
890 g_setup = find_global 'Foo', 'setup'
892 g_sanity = find_global 'Foo', 'check_sanity'
894 g_mutate = find_global 'Foo', 'mutate'
896 g_value = find_global 'Foo', 'check_value'
926 store_global 'test_num', $P0
928 .const .Sub _check = 'full_check'
931 $P0 = new ParrotThread
932 $P0.'run_clone'(_check)
938 <<'CODE', <<'OUTPUT', "CLONE_CODE|CLONE_GLOBALS|CLONE_HLL|CLONE_LIBRARIES", todo => 'RT#41373' );
939 .HLL 'Perl', 'perl_group'
941 .include 'interpinfo.pasm'
946 .param pmc passed_value
947 .local int PerlIntType
949 PerlIntType = find_type 'PerlInt'
950 the_value = new PerlIntType
952 store_global 'Foo', 'x', the_value
953 $I0 = typeof passed_value
954 $I1 = typeof the_value
959 ns = get_namespace ['Foo']
960 $P0 = interpinfo .INTERPINFO_CURRENT_SUB
961 ns = $P0.'get_namespace'()
964 if $P0 == the_value goto okay
974 .include 'cloneflags.pasm'
979 thread = new ParrotThread
980 flags = .PARROT_CLONE_CODE
981 bor flags, flags, .PARROT_CLONE_GLOBALS
982 bor flags, flags, .PARROT_CLONE_HLL
983 bor flags, flags, .PARROT_CLONE_LIBRARIES
986 .local int PerlIntType
987 PerlIntType = find_type 'PerlInt'
988 passed = new PerlIntType
991 .local pmc thread_func
992 thread_func = global 'test'
994 thread.'run'(flags, thread_func, passed)
1010 pir_output_is( <<'CODE', <<'OUT', 'multi-threaded strings via SharedRef' );
1013 .local pmc tmp_string
1014 .local pmc shared_ref
1017 tmp_string = new String
1018 tmp_string = "ok 1\n"
1019 shared_ref = new SharedRef, tmp_string
1020 push queue, shared_ref
1021 tmp_string = new String
1022 tmp_string = "ok 2\n"
1023 shared_ref = new SharedRef, tmp_string
1024 push queue, shared_ref
1025 tmp_string = new String
1026 tmp_string = "ok 3\n"
1027 shared_ref = new SharedRef, tmp_string
1028 push queue, shared_ref
1033 thread = new ParrotThread
1035 thread.'run_clone'(foo, queue)
1047 if $I0 == 0 goto done
1052 print "done thread\n"
1064 skip( "no shared Strings yet", 2 );
1065 pasm_output_is( <<'CODE', <<'OUT', "thread safe queue strings 1" );
1094 pasm_output_is( <<'CODE', <<'OUT', "multi-threaded strings" );
1107 find_global P5, "_foo"
1108 new P2, .ParrotThread
1109 callmethod "thread3"
1127 print "done thread\n"
1141 # cperl-indent-level: 4
1144 # vim: expandtab shiftwidth=4: