From: Jerry D. Hedden Date: Mon, 3 Apr 2006 06:10:35 +0000 (-0700) Subject: 2nd patch to sync blead 'threads' with CPAN [REPOST] X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f4cc38afb863043fd1f03a9637328ab5e1d16ea3;p=p5sagit%2Fp5-mst-13.2.git 2nd patch to sync blead 'threads' with CPAN [REPOST] From: "Jerry D. Hedden" Message-ID: <20060403061035.fb30e530d17747c2b054d625b8945d88.7482c755b8.wbe@email.email.secureserver.net> p4raw-id: //depot/perl@27705 --- diff --git a/ext/threads/Changes b/ext/threads/Changes index cda33b2..52b1623 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -1,5 +1,10 @@ Revision history for Perl extension threads. +1.18 Fri Mar 24 14:21:36 EST 2006 + - ->equal returns 0 on false for backwards compatibility + - Changed UVs to IVs in XS code (except for TID) + - Use ->create in tests + 1.17 Thu Mar 23 10:31:20 EST 2006 - Restoration of 'core' build parameters diff --git a/ext/threads/README b/ext/threads/README index ce7d554..b469884 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.17 +threads version 1.18 ==================== This module needs perl 5.8.0 or later compiled with 'useithreads'. diff --git a/ext/threads/t/basic.t b/ext/threads/t/basic.t index a4c4fef..3a9ab17 100755 --- a/ext/threads/t/basic.t +++ b/ext/threads/t/basic.t @@ -1,19 +1,6 @@ use strict; use warnings; -# -# The reason this does not use a Test module is that -# they mess up test numbers between threads -# -# And even when that will be fixed, this is a basic -# test and should not rely on shared variables -# -# This will test the basic API, it will not use any coderefs -# as they are more advanced -# -######################### - - BEGIN { if ($ENV{'PERL_CORE'}){ chdir 't'; @@ -28,7 +15,7 @@ BEGIN { use ExtUtils::testlib; -BEGIN { $| = 1; print "1..28\n" }; +BEGIN { $| = 1; print "1..30\n" }; use threads; @@ -147,22 +134,25 @@ my $thr3 = threads->object($thr1->tid()); ok(20, $thr1 != $thr2, 'Treads not equal'); ok(21, $thr1 == $thr3, 'Threads equal'); -ok(22, threads->object($thr1->tid())->tid() == 11, 'Object method'); -ok(23, threads->object($thr2->tid())->tid() == 12, 'Object method'); +ok(22, $thr1->_handle(), 'Handle method'); +ok(23, $thr2->_handle(), 'Handle method'); + +ok(24, threads->object($thr1->tid())->tid() == 11, 'Object method'); +ok(25, threads->object($thr2->tid())->tid() == 12, 'Object method'); $thr1->join(); $thr2->join(); -my $sub = sub { ok(24, shift() == 1, "Test code ref"); }; +my $sub = sub { ok(26, shift() == 1, "Test code ref"); }; threads->create($sub, 1)->join(); my $thrx = threads->object(99); -ok(25, ! defined($thrx), 'No object'); +ok(27, ! defined($thrx), 'No object'); $thrx = threads->object(); -ok(26, ! defined($thrx), 'No object'); +ok(28, ! defined($thrx), 'No object'); $thrx = threads->object(undef); -ok(27, ! defined($thrx), 'No object'); +ok(29, ! defined($thrx), 'No object'); $thrx = threads->object(0); -ok(28, ! defined($thrx), 'No object'); +ok(30, ! defined($thrx), 'No object'); # EOF diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t index a395f78..52cdf6a 100644 --- a/ext/threads/t/join.t +++ b/ext/threads/t/join.t @@ -102,7 +102,7 @@ ok(1,""); if ($^O eq 'linux') { # First modify $0 in a subthread. print "# mainthread: \$0 = $0\n"; - threads->new( sub { + threads->create( sub { print "# subthread: \$0 = $0\n"; $0 = "foobar"; print "# subthread: \$0 = $0\n" } )->join; @@ -135,9 +135,9 @@ if ($^O eq 'linux') { } { - my $t = threads->new(sub {}); + my $t = threads->create(sub {}); $t->join; - my $x = threads->new(sub {}); + my $x = threads->create(sub {}); $x->join; eval { $t->join; @@ -153,6 +153,6 @@ if ($^O eq 'linux') { # archives for the thread "maint@20974 or before broke mp2 ithreads test". use IO::File; # this coredumped between #20930 and #21000 - $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2; + $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2; } diff --git a/ext/threads/t/list.t b/ext/threads/t/list.t index 0e3c5b2..4f5f276 100644 --- a/ext/threads/t/list.t +++ b/ext/threads/t/list.t @@ -17,7 +17,7 @@ use ExtUtils::testlib; -BEGIN { $| = 1; print "1..8\n" }; +BEGIN { $| = 1; print "1..15\n" }; use threads; @@ -37,21 +37,36 @@ sub ok { return $ok; } -ok(2, scalar @{[threads->list]} == 0,''); - +### Start of Testing ### +ok(2, scalar @{[threads->list()]} == 0, 'No threads yet'); threads->create(sub {})->join(); -ok(3, scalar @{[threads->list]} == 0,''); +ok(3, scalar @{[threads->list()]} == 0, 'Empty thread list after join'); my $thread = threads->create(sub {}); -ok(4, scalar @{[threads->list]} == 1,''); +ok(4, scalar(threads->list()) == 1, 'Non-empty thread list'); +ok(5, threads->list() == 1, 'Non-empty thread list'); $thread->join(); -ok(5, scalar @{[threads->list]} == 0,''); +ok(6, scalar @{[threads->list()]} == 0, 'Thread list empty again'); +ok(7, threads->list() == 0, 'Thread list empty again'); + +$thread = threads->create(sub { + ok(8, threads->list() == 1, 'Non-empty thread list in thread'); + ok(9, threads->self == (threads->list())[0], 'Self in thread list') +}); -$thread = threads->create(sub { ok(6, threads->self == (threads->list)[0],'')}); threads->yield; # help out non-preemptive thread implementations sleep 1; -ok(7, $thread == (threads->list)[0],''); + +ok(10, scalar(threads->list()) == 1, 'Thread count 1'); +ok(11, threads->list() == 1, 'Thread count 1'); +my $cnt = threads->list(); +ok(12, $cnt == 1, 'Thread count 1'); +my ($thr_x) = threads->list(); +ok(13, $thread == $thr_x, 'Thread in list'); $thread->join(); -ok(8, scalar @{[threads->list]} == 0,''); +ok(14, scalar @{[threads->list()]} == 0, 'Thread list empty'); +ok(15, threads->list() == 0, 'Thread list empty'); + +# EOF diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t index d832124..f590994 100644 --- a/ext/threads/t/problems.t +++ b/ext/threads/t/problems.t @@ -85,7 +85,7 @@ sub is($$$) { ######################### if ($] == 5.008 || $] >= 5.008003) { - threads->new( sub {1} )->join; + threads->create( sub {1} )->join; my $not = eval { Config::myconfig() } ? '' : 'not '; print "${not}ok $test - Are we able to call Config::myconfig after clone\n"; } else { @@ -99,7 +99,7 @@ $test++; our $unique_scalar : unique; our @unique_array : unique; our %unique_hash : unique; -threads->new( +threads->create( sub { my $TODO = ":unique needs to be re-implemented in a non-broken way"; eval { $unique_scalar = 1 }; @@ -147,7 +147,7 @@ for my $decl ('my $x : unique', 'sub foo : unique') { # sub { $x."bar" }; # } # -# my $string = threads->new(\&f)->join->(); +# my $string = threads->create(\&f)->join->(); # print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n"; # $test++; @@ -157,7 +157,7 @@ for my $decl ('my $x : unique', 'sub foo : unique') { my %h = (1,2,3,4); is (keys %h, 2, "keys correct in parent"); -my $child = threads->new(sub { return scalar keys %h })->join; +my $child = threads->create(sub { return scalar keys %h })->join; is ($child, 2, "keys correct in child"); lock_keys (%h); @@ -165,7 +165,7 @@ delete $h{1}; is (keys %h, 1, "keys correct in parent with restricted hash"); -$child = threads->new(sub { return scalar keys %h })->join; +$child = threads->create(sub { return scalar keys %h })->join; is ($child, 1, "keys correct in child with restricted hash"); 1; diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index befc4a4..15533a9 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -28,7 +28,7 @@ sub content { return shift; } { - my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000); + my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000); print $t->join(); } { @@ -36,7 +36,7 @@ sub content { my $t; { lock($lock); - $t = threads->new(sub { lock($lock); print "ok 5\n"}); + $t = threads->create(sub { lock($lock); print "ok 5\n"}); print "ok 4\n"; } $t->join(); @@ -47,18 +47,18 @@ sub dorecurse { my $ret; print $val; if(@_) { - $ret = threads->new(\&dorecurse, @_); + $ret = threads->create(\&dorecurse, @_); $ret->join; } } { - my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10); + my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10); $t->join(); } { # test that sleep lets other thread run - my $t = threads->new(\&dorecurse, "ok 11\n"); + my $t = threads->create(\&dorecurse, "ok 11\n"); threads->yield; # help out non-preemptive thread implementations sleep 1; print "ok 12\n"; @@ -72,11 +72,11 @@ sub dorecurse { my $ret; print $val; if (@_) { - $ret = threads->new(\&islocked, shift); + $ret = threads->create(\&islocked, shift); } return $ret; } -my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n"); +my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n"); $t->join->join; } @@ -103,8 +103,8 @@ sub threaded { { curr_test(15); - my $thr1 = threads->new(\&testsprintf, 15); - my $thr2 = threads->new(\&testsprintf, 16); + my $thr1 = threads->create(\&testsprintf, 15); + my $thr2 = threads->create(\&testsprintf, 16); my $short = "This is a long string that goes on and on."; my $shorte = " a long string that goes on and on."; @@ -150,7 +150,7 @@ package main; # since it tests rand my %rand : shared; rand(10); - threads->new( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; + threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; $_->join foreach threads->list; # use Data::Dumper qw(Dumper); # print Dumper(\%rand); @@ -161,7 +161,7 @@ package main; # bugid #24165 run_perl(prog => - 'use threads; sub a{threads->new(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid'); + 'use threads; sub a{threads->create(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid'); is($?, 0, 'coredump in global destruction'); # test CLONE_SKIP() functionality @@ -233,7 +233,7 @@ if ($] >= 5.008007) { $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs; is($cloned, ($depth ? '00010001111' : '11111111111'), "objs clone skip at depth $depth"); - threads->new( \&f, $depth+1)->join if $depth < 2; + threads->create( \&f, $depth+1)->join if $depth < 2; @objs = (); } f(0); diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index fdd9c01..78d328e 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -38,7 +38,7 @@ BEGIN { if($threads::shared::threads_shared); } -our $VERSION = '1.17'; +our $VERSION = '1.18'; # Load the XS code @@ -76,25 +76,14 @@ sub import ### Methods, etc. ### -# || 0 to ensure compatibility with previous versions -sub equal { ($_[0]->tid == $_[1]->tid) || 0 } - # use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2) # should also be faster sub async (&;@) { unshift @_,'threads'; goto &new } -sub object { - return undef unless @_ > 1; - foreach (threads->list) { - return $_ if $_->tid == $_[1]; - } - return undef; -} - $threads::threads = 1; -# why document 'new' then use 'create' in the tests! -*create = \&new; +# 'new' is an alias for 'create' +*new = \&create; 1; @@ -106,7 +95,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.17 +This document describes threads version 1.18 =head1 SYNOPSIS @@ -276,9 +265,10 @@ thread implementation. You may do C then use just a bare C in your code. -=item threads->list(); +=item threads->list() -This will return a list of all non joined, non detached threads. +In a list context, returns a list of all non-joined, non-detached I +objects. In a scalar context, returns a count of the same. =item $thr1->equal($thr2) @@ -298,6 +288,22 @@ it. This block is treated as an anonymous sub, and so must have a semi-colon after the closing brace. Like C<< threads->new >>, C returns a thread object. +=item $thr->_handle() + +This I method returns the memory location of the internal thread +structure associated with a threads object. For Win32, this is the handle +returned by C; for other platforms, it is the pointer returned +by C. + +This method is of no use for general Perl threads programming. Its intent is +to provide other (XS-based) thread modules with the capability to access, and +possibly manipulate, the underlying thread structure associated with a Perl +thread. + +=item threads->_handle() + +Class method that allows a thread to obtain its own I. + =back =head1 WARNINGS @@ -338,11 +344,6 @@ incompatible.) On some platforms it might not be possible to destroy "parent" threads while there are still existing child "threads". -=item tid is I32 - -The thread id is a 32 bit integer, it can potentially overflow. -This might be fixed in a later version of perl. - =item Creating threads inside BEGIN blocks Creating threads inside BEGIN blocks (or during the compilation phase @@ -385,7 +386,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L L, L diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 0cbe208..3f4716d 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -43,9 +43,9 @@ typedef struct ithread_s { struct ithread_s *next; /* Next thread in the list */ struct ithread_s *prev; /* Prev thread in the list */ PerlInterpreter *interp; /* The threads interpreter */ - I32 tid; /* Threads module's thread id */ + UV tid; /* Threads module's thread id */ perl_mutex mutex; /* Mutex for updating things in this struct */ - I32 count; /* How many SVs have a reference to us */ + IV count; /* How many SVs have a reference to us */ signed char state; /* Are we detached ? */ int gimme; /* Context of create */ SV* init_function; /* Code to run */ @@ -67,30 +67,24 @@ typedef struct { START_MY_CXT -ithread *threads; - -/* Macros to supply the aTHX_ in an embed.h like manner */ -#define ithread_join(thread) Perl_ithread_join(aTHX_ thread) -#define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread) -#define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread) -#define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread) -#define ithread_tid(thread) ((thread)->tid) -#define ithread_yield(thread) (YIELD); +static ithread *threads; static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/ -I32 tid_counter = 0; -I32 known_threads = 0; -I32 active_threads = 0; +static UV tid_counter = 0; +static IV known_threads = 0; +static IV active_threads = 0; -void Perl_ithread_set (pTHX_ ithread* thread) +static void +Perl_ithread_set (pTHX_ ithread* thread) { dMY_CXT; MY_CXT.thread = thread; } -ithread* Perl_ithread_get (pTHX) { +static ithread* +Perl_ithread_get (pTHX) { dMY_CXT; return MY_CXT.thread; } @@ -192,7 +186,7 @@ Perl_ithread_hook(pTHX) if (aTHX == PL_curinterp && active_threads != 1) { if (ckWARN_d(WARN_THREADS)) Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", - (IV)active_threads); + active_threads); veto_cleanup = 1; } MUTEX_UNLOCK(&create_destruct_mutex); @@ -284,10 +278,10 @@ MGVTBL ithread_vtbl = { */ #ifdef WIN32 -THREAD_RET_TYPE +static THREAD_RET_TYPE Perl_ithread_run(LPVOID arg) { #else -void* +static void* Perl_ithread_run(void * arg) { #endif ithread* thread = (ithread*) arg; @@ -310,22 +304,22 @@ Perl_ithread_run(void * arg) { { AV* params = (AV*) SvRV(thread->params); - I32 len = av_len(params)+1; - int i; + int len = (int)av_len(params)+1; + int ii; dSP; ENTER; SAVETMPS; PUSHMARK(SP); - for(i = 0; i < len; i++) { + for(ii = 0; ii < len; ii++) { XPUSHs(av_shift(params)); } PUTBACK; - len = call_sv(thread->init_function, thread->gimme|G_EVAL); + len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); SPAGAIN; - for (i=len-1; i >= 0; i--) { + for (ii=len-1; ii >= 0; ii--) { SV *sv = POPs; - av_store(params, i, SvREFCNT_inc(sv)); + av_store(params, ii, SvREFCNT_inc(sv)); } if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV); @@ -357,7 +351,7 @@ Perl_ithread_run(void * arg) { #endif } -SV * +static SV * ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) { SV *sv; @@ -377,7 +371,7 @@ ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) return obj; } -ithread * +static ithread * SV_to_ithread(pTHX_ SV *sv) { if (SvROK(sv)) @@ -395,7 +389,7 @@ SV_to_ithread(pTHX_ SV *sv) * Called in context of parent thread */ -SV * +static SV * Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) { ithread* thread; @@ -403,7 +397,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param ithread* current_thread = Perl_ithread_get(aTHX); SV** tmps_tmp = PL_tmps_stack; - I32 tmps_ix = PL_tmps_ix; + IV tmps_ix = PL_tmps_ix; #ifndef WIN32 int failure; const char* panic = NULL; @@ -572,7 +566,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); } -SV* +static SV* Perl_ithread_self (pTHX_ SV *obj, char* Class) { ithread *thread = Perl_ithread_get(aTHX); @@ -583,23 +577,11 @@ Perl_ithread_self (pTHX_ SV *obj, char* Class) return NULL; /* silence compiler warning */ } -/* - * Joins the thread this code needs to take the returnvalue from the - * call_sv and send it back - */ -void -Perl_ithread_CLONE(pTHX_ SV *obj) -{ - if (SvROK(obj)) { - ithread *thread = SV_to_ithread(aTHX_ obj); - } - else if (ckWARN_d(WARN_THREADS)) { - Perl_warn(aTHX_ "CLONE %" SVf,obj); - } -} - -AV* +/* Joins the thread. + * This code takes the return value from the call_sv and sends it back. + */ +static AV* Perl_ithread_join(pTHX_ SV *obj) { ithread *thread = SV_to_ithread(aTHX_ obj); @@ -681,7 +663,7 @@ Perl_ithread_join(pTHX_ SV *obj) return (AV*)NULL; } -void +static void Perl_ithread_DESTROY(pTHX_ SV *sv) { ithread *thread = SV_to_ithread(aTHX_ sv); @@ -696,83 +678,222 @@ PROTOTYPES: DISABLE #ifdef USE_ITHREADS void -ithread_new (classname, function_to_call, ...) -char * classname -SV * function_to_call -CODE: -{ - AV* params = newAV(); - if (items > 2) { - int i; - for(i = 2; i < items ; i++) { - av_push(params, SvREFCNT_inc(ST(i))); - } - } - ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params))); - XSRETURN(1); -} +ithread_create(...) + PREINIT: + char *classname; + SV *function_to_call; + AV *params; + int ii; + CODE: + if (items < 2) + Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); + + classname = (char *)SvPV_nolen(ST(0)); + function_to_call = ST(1); + + /* Function args */ + params = newAV(); + if (items > 2) { + for (ii=2; ii < items; ii++) { + av_push(params, SvREFCNT_inc(ST(ii))); + } + } + + /* Create thread */ + ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, + classname, + function_to_call, + newRV_noinc((SV*)params))); + /* XSRETURN(1); - implied */ + void -ithread_list(char *classname) -PPCODE: -{ - ithread *curr_thread; - MUTEX_LOCK(&create_destruct_mutex); - curr_thread = threads; - if(curr_thread->tid != 0) - XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); - while(curr_thread) { - curr_thread = curr_thread->next; - if(curr_thread == threads) - break; - if(curr_thread->state & PERL_ITHR_DETACHED || - curr_thread->state & PERL_ITHR_JOINED) - continue; - XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); - } - MUTEX_UNLOCK(&create_destruct_mutex); -} +ithread_list(...) + PREINIT: + char *classname; + ithread *thr; + int list_context; + IV count = 0; + PPCODE: + /* Class method only */ + if (SvROK(ST(0))) + Perl_croak(aTHX_ "Usage: threads->list()"); + classname = (char *)SvPV_nolen(ST(0)); + + /* Calling context */ + list_context = (GIMME_V == G_ARRAY); + + /* Walk through threads list */ + MUTEX_LOCK(&create_destruct_mutex); + for (thr = threads->next; + thr != threads; + thr = thr->next) + { + /* Ignore detached or joined threads */ + if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { + continue; + } + /* Push object on stack if list context */ + if (list_context) { + XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE))); + } + count++; + } + MUTEX_UNLOCK(&create_destruct_mutex); + /* If scalar context, send back count */ + if (! list_context) { + XSRETURN_IV(count); + } void -ithread_self(char *classname) -CODE: -{ - ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname)); - XSRETURN(1); -} +ithread_self(...) + PREINIT: + char *classname; + CODE: + /* Class method only */ + if (SvROK(ST(0))) + Perl_croak(aTHX_ "Usage: threads->self()"); + classname = (char *)SvPV_nolen(ST(0)); + + ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv, classname)); + /* XSRETURN(1); - implied */ -int -ithread_tid(ithread *thread) void -ithread_join(SV *obj) -PPCODE: -{ - AV* params = Perl_ithread_join(aTHX_ obj); - int i; - I32 len = AvFILL(params); - for (i = 0; i <= len; i++) { - SV* tmp = av_shift(params); - XPUSHs(tmp); - sv_2mortal(tmp); - } - SvREFCNT_dec(params); -} +ithread_tid(...) + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); + XST_mUV(0, thread->tid); + /* XSRETURN(1); - implied */ + void -yield(...) -CODE: -{ - YIELD; -} - +ithread_join(...) + PREINIT: + AV *params; + int len; + int ii; + PPCODE: + /* Object method only */ + if (! sv_isobject(ST(0))) + Perl_croak(aTHX_ "Usage: $thr->join()"); + + /* Join thread and get return values */ + params = Perl_ithread_join(aTHX_ ST(0)); + if (! params) { + XSRETURN_UNDEF; + } + + /* Put return values on stack */ + len = (int)AvFILL(params); + for (ii=0; ii <= len; ii++) { + SV* param = av_shift(params); + XPUSHs(sv_2mortal(param)); + } + + /* Free return value array */ + SvREFCNT_dec(params); + + +void +ithread_yield(...) + CODE: + YIELD; + + +void +ithread_detach(...) + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); + Perl_ithread_detach(aTHX_ thread); + void -ithread_detach(ithread *thread) +ithread_DESTROY(...) + CODE: + Perl_ithread_DESTROY(aTHX_ ST(0)); + + +void +ithread_equal(...) + CODE: + /* Compares TIDs to determine thread equality. + * Return 0 on false for backward compatibility. + */ + if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { + ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); + if (thr1->tid == thr2->tid) { + XST_mYES(0); + } else { + XST_mIV(0, 0); + } + } else { + XST_mIV(0, 0); + } + /* XSRETURN(1); - implied */ + void -ithread_DESTROY(SV *thread) +ithread_object(...) + PREINIT: + char *classname; + UV tid; + ithread *thr; + int found = 0; + CODE: + /* Class method only */ + if (SvROK(ST(0))) + Perl_croak(aTHX_ "Usage: threads->object($tid)"); + classname = (char *)SvPV_nolen(ST(0)); + + if ((items < 2) || ! SvOK(ST(1))) { + XSRETURN_UNDEF; + } + + tid = SvUV(ST(1)); + + /* Walk through threads list */ + MUTEX_LOCK(&create_destruct_mutex); + for (thr = threads->next; + thr != threads; + thr = thr->next) + { + /* Look for TID, but ignore detached or joined threads */ + if ((thr->tid != tid) || + (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) + { + continue; + } + /* Put object on stack */ + ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)); + found = 1; + break; + } + MUTEX_UNLOCK(&create_destruct_mutex); + if (! found) { + XSRETURN_UNDEF; + } + /* XSRETURN(1); - implied */ + + +void +ithread__handle(...); + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); +#ifdef WIN32 + XST_mUV(0, PTR2UV(thread->handle)); +#else + XST_mUV(0, PTR2UV(thread->thr)); +#endif + /* XSRETURN(1); - implied */ #endif /* USE_ITHREADS */