dslinux/user/perl/ext/Thread Makefile.PL Notes Queue.pmx README README.threads Semaphore.pmx Thread.xs create.tx die.tx die2.tx io.tx join.tx join2.tx list.tx lock.tx queue.tx specific.tx sync.tx sync2.tx thr5005.t typemap unsync.tx unsync2.tx unsync3.tx unsync4.tx

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:46 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/ext/Thread
In directory antilope:/tmp/cvs-serv17422/ext/Thread

Added Files:
	Makefile.PL Notes Queue.pmx README README.threads 
	Semaphore.pmx Thread.xs create.tx die.tx die2.tx io.tx join.tx 
	join2.tx list.tx lock.tx queue.tx specific.tx sync.tx sync2.tx 
	thr5005.t typemap unsync.tx unsync2.tx unsync3.tx unsync4.tx 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: specific.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

use Thread::Specific qw(foo);

sub count {
    my $tid = Thread->self->tid;
    my Thread::Specific $tsd = Thread::Specific::data;
    for (my $i = 0; $i < 5; $i++) {
	$tsd->{foo} = $i;
	print "thread $tid count: $tsd->{foo}\n";
	select(undef, undef, undef, rand(2));
    }
};

for(my $t = 0; $t < 5; $t++) {
    new Thread \&count;
}

--- NEW FILE: thr5005.t ---
#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require Config; import Config;
    if (! $Config{'use5005threads'}) {
	print "1..0 # Skip: no use5005threads\n";
	exit 0;
    }

    # XXX known trouble with global destruction
    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
}
$| = 1;
print "1..74\n";
use Thread 'yield';
print "ok 1\n";

sub content
{
 print shift;
 return shift;
}

# create a thread passing args and immedaietly wait for it.
my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000);
print $t->join;

# check that lock works ...
{lock $foo;
 $t = new Thread sub { lock $foo; print "ok 5\n" };
 print "ok 4\n";
}
$t->join;

sub dorecurse
{
 my $val = shift;
 my $ret;
 print $val;
 if (@_)
  {
   $ret = Thread->new(\&dorecurse, @_);
   $ret->join;
  }
}

$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10;
$t->join;

# test that sleep lets other thread run
$t = new Thread \&dorecurse,"ok 11\n";
sleep 6;
print "ok 12\n";
$t->join;

sub islocked : locked {
 my $val = shift;
 my $ret;
 print $val;
 if (@_)
  {
   $ret = Thread->new(\&islocked, shift);
  }
 $ret;
}

$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n");
$t->join->join;

{
    package Loch::Ness;
    sub new { bless [], shift }
    sub monster : locked : method {
	my($s, $m) = @_;
	print "ok $m\n";
    }
    sub gollum { &monster }
}
Loch::Ness->monster(15);
Loch::Ness->new->monster(16);
Loch::Ness->gollum(17);
Loch::Ness->new->gollum(18);

my $short = "This is a long string that goes on and on.";
my $shorte = " a long string that goes on and on.";
my $long  = "This is short.";
my $longe  = " short.";
my $thr1 = new Thread \&threaded, $short, $shorte, "19";
my $thr2 = new Thread \&threaded, $long, $longe, "20";
my $thr3 = new Thread \&testsprintf, "21";

sub testsprintf {
  my $testno = shift;
  # this may coredump if thread vars are not properly initialised
  my $same = sprintf "%.0f", $testno;
  if ($testno eq $same) {
    print "ok $testno\n";
  } else {
    print "not ok $testno\t# '$testno' ne '$same'\n";
  }
}

sub threaded {
  my ($string, $string_end, $testno) = @_;

  # Do the match, saving the output in appropriate variables
  $string =~ /(.*)(is)(.*)/;
  # Yield control, allowing the other thread to fill in the match variables
  yield();
  # Examine the match variable contents; on broken perls this fails
  if ($3 eq $string_end) {
    print "ok $testno\n";
  }
  else {
    warn <<EOT;

#
# This is a KNOWN FAILURE, and one of the reasons why threading
# is still an experimental feature.  It is here to stop people
# from deploying threads in production. ;-)
#
EOT
    print "not ok $testno # other thread filled in match variables\n";
  }
}
$thr1->join;
$thr2->join;
$thr3->join;
print "ok 22\n";

{
    my $THRf_STATE_MASK = 7;
    my $THRf_R_JOINABLE = 0;
    my $THRf_R_JOINED = 1;
    my $THRf_R_DETACHED = 2;
    my $THRf_ZOMBIE = 3;
    my $THRf_DEAD = 4;
    my $THRf_DID_DIE = 8;
    sub _test {
	my($test, $t, $state, $die) = @_;
	my $flags = $t->flags;
	if (($flags & $THRf_STATE_MASK) == $state
		&& !($flags & $THRf_DID_DIE) == !$die) {
	    print "ok $test\n";
	} else {
	    print <<BAD;
not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]}
BAD
	}
    }

    my @t;
    push @t, (
	Thread->new(sub { sleep 4; die "thread die\n" }),
	Thread->new(sub { die "thread die\n" }),
	Thread->new(sub { sleep 4; 1 }),
	Thread->new(sub { 1 }),
    ) for 1, 2;
    $_->detach for @t[grep $_ & 4, 0..$#t];

    sleep 1;
    my $test = 23;
    for (0..7) {
	my $t = $t[$_];
	my $flags = ($_ & 1)
	    ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE
	    : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
	_test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
	printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
    }
#   $test = 39;
    for (grep $_ & 1, 0..$#t) {
	next if $_ & 4;		# can't join detached threads
	$t[$_]->eval;
	my $die = ($_ & 2) ? "" : "thread die\n";
	printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
    }
#   $test = 41;
    for (0..7) {
	my $t = $t[$_];
	my $flags = ($_ & 1)
	    ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
	    : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
	_test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
	printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
    }
#   $test = 57;
    for (grep !($_ & 1), 0..$#t) {
	next if $_ & 4;		# can't join detached threads
	$t[$_]->eval;
	my $die = ($_ & 2) ? "" : "thread die\n";
	printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
    }
    sleep 1;	# make sure even the detached threads are done sleeping
#   $test = 59;
    for (0..7) {
	my $t = $t[$_];
	my $flags = ($_ & 1)
	    ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
	    : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD;
	_test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE);
	printf "%sok %s\n", $t->done ? "" : "not ", $test++;
    }
#   $test = 75;
}

--- NEW FILE: Semaphore.pmx ---
package Thread::Semaphore;
use Thread qw(cond_wait cond_broadcast);

use vars qw($VERSION);
$VERSION = '1.00';

=head1 NAME

Thread::Semaphore - thread-safe semaphores (5.005-threads)

=head1 CAVEAT

This Perl installation is using the old unsupported "5.005 threads".
Use of the old threads model is discouraged.

For the whole story about the development of threads in Perl, and why
you should B<not> be using "old threads" unless you know what you're
doing, see the CAVEAT of the C<Thread> module.

=head1 SYNOPSIS

    use Thread::Semaphore;
    my $s = new Thread::Semaphore;
    $s->up;	# Also known as the semaphore V -operation.
    # The guarded section is here
    $s->down;	# Also known as the semaphore P -operation.

    # The default semaphore value is 1.
    my $s = new Thread::Semaphore($initial_value);
    $s->up($up_value);
    $s->down($up_value);

=head1 DESCRIPTION

Semaphores provide a mechanism to regulate access to resources. Semaphores,
unlike locks, aren't tied to particular scalars, and so may be used to
control access to anything you care to use them for.

Semaphores don't limit their values to zero or one, so they can be used to
control access to some resource that may have more than one of. (For
example, filehandles) Increment and decrement amounts aren't fixed at one
either, so threads can reserve or return multiple resources at once.

=head1 FUNCTIONS AND METHODS

=over 8

=item new

=item new NUMBER

C<new> creates a new semaphore, and initializes its count to the passed
number. If no number is passed, the semaphore's count is set to one.

=item down

=item down NUMBER

The C<down> method decreases the semaphore's count by the specified number,
or one if no number has been specified. If the semaphore's count would drop
below zero, this method will block until such time that the semaphore's
count is equal to or larger than the amount you're C<down>ing the
semaphore's count by.

=item up

=item up NUMBER

The C<up> method increases the semaphore's count by the number specified,
or one if no number's been specified. This will unblock any thread blocked
trying to C<down> the semaphore if the C<up> raises the semaphore count
above what the C<down>s are trying to decrement it by.

=back

=cut

sub new {
    my $class = shift;
    my $val = @_ ? shift : 1;
    bless \$val, $class;
}

sub down : locked : method {
    my $s = shift;
    my $inc = @_ ? shift : 1;
    cond_wait $s until $$s >= $inc;
    $$s -= $inc;
}

sub up : locked : method {
    my $s = shift;
    my $inc = @_ ? shift : 1;
    ($$s += $inc) > 0 and cond_broadcast $s;
}

1;

--- NEW FILE: unsync.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$| = 1;

if (@ARGV) {
    srand($ARGV[0]);
} else {
    my $seed = $$ ^ $^T;
    print "Randomising to $seed\n";
    srand($seed);
}

sub whoami {
    my ($depth, $a, $b, $c) = @_;
    my $i;
    print "whoami ($depth): $a $b $c\n";
    sleep 1;
    whoami($depth - 1, $a, $b, $c) if $depth > 0;
}

sub start_foo {
    my $r = 3 + int(10 * rand);
    print "start_foo: r is $r\n";
    whoami($r, "start_foo", "foo1", "foo2");
    print "start_foo: finished\n";
}

sub start_bar {
    my $r = 3 + int(10 * rand);
    print "start_bar: r is $r\n";
    whoami($r, "start_bar", "bar1", "bar2");
    print "start_bar: finished\n";
}

$foo = new Thread \&start_foo;
$bar = new Thread \&start_bar;
print "main: exiting\n";

--- NEW FILE: unsync4.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$| = 1;

srand($$^$^T);

sub printargs {
    my(@copyargs) = @_;
    my $thread = shift @copyargs;
    my $arg;
    my $i;
    while ($arg = shift @copyargs) {
	my $delay = int(rand(500));
	$i++;
	print "$thread arg $i is $arg\n";
	1 while $delay--;
    }
}

sub start_thread {
    my(@threadargs) = @_;
    my $thread = $threadargs[0];
    my $count = 10;
    while ($count--) {
	my(@args) = ($thread) x int(rand(10));
	print "$thread $count calling printargs @args\n";
	printargs($thread, @args);
    }
}

new Thread (\&start_thread, "A");
new Thread (\&start_thread, "B");
new Thread (\&start_thread, "C");
new Thread (\&start_thread, "D");
new Thread (\&start_thread, "E");
new Thread (\&start_thread, "F");

print "main: exiting\n";

--- NEW FILE: Queue.pmx ---
package Thread::Queue;
use Thread qw(cond_wait cond_broadcast);

use vars qw($VERSION);
$VERSION = '1.00';

=head1 NAME

Thread::Queue - thread-safe queues (5.005-threads)

=head1 CAVEAT

This Perl installation is using the old unsupported "5.005 threads".
Use of the old threads model is discouraged.

For the whole story about the development of threads in Perl, and why
you should B<not> be using "old threads" unless you know what you're
doing, see the CAVEAT of the C<Thread> module.

=head1 SYNOPSIS

    use Thread::Queue;
    my $q = new Thread::Queue;
    $q->enqueue("foo", "bar");
    my $foo = $q->dequeue;    # The "bar" is still in the queue.
    my $foo = $q->dequeue_nb; # returns "bar", or undef if the queue was
                              # empty
    my $left = $q->pending;   # returns the number of items still in the queue

=head1 DESCRIPTION

A queue, as implemented by C<Thread::Queue> is a thread-safe data structure
much like a list. Any number of threads can safely add elements to the end
of the list, or remove elements from the head of the list. (Queues don't
permit adding or removing elements from the middle of the list)

=head1 FUNCTIONS AND METHODS

=over 8

=item new

The C<new> function creates a new empty queue.

=item enqueue LIST

The C<enqueue> method adds a list of scalars on to the end of the queue.
The queue will grow as needed to accomodate the list.

=item dequeue

The C<dequeue> method removes a scalar from the head of the queue and
returns it. If the queue is currently empty, C<dequeue> will block the
thread until another thread C<enqueue>s a scalar.

=item dequeue_nb

The C<dequeue_nb> method, like the C<dequeue> method, removes a scalar from
the head of the queue and returns it. Unlike C<dequeue>, though,
C<dequeue_nb> won't block if the queue is empty, instead returning
C<undef>.

=item pending

The C<pending> method returns the number of items still in the queue.  (If
there can be multiple readers on the queue it's best to lock the queue
before checking to make sure that it stays in a consistent state)

=back

=head1 SEE ALSO

L<Thread>
  
=cut

sub new {
    my $class = shift;
    return bless [@_], $class;
}

sub dequeue : locked : method {
    my $q = shift;
    cond_wait $q until @$q;
    return shift @$q;
}

sub dequeue_nb : locked : method {
  my $q = shift;
  if (@$q) {
    return shift @$q;
  } else {
    return undef;
  }
}

sub enqueue : locked : method {
    my $q = shift;
    push(@$q, @_) and cond_broadcast $q;
}

sub pending : locked : method {
  my $q = shift;
  return scalar(@$q);
}

1;

--- NEW FILE: unsync2.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$| = 1;

srand($$^$^T);

sub printargs {
    my $thread = shift;
    my $arg;
    my $i;
    while ($arg = shift) {
	my $delay = int(rand(500));
	$i++;
	print "$thread arg $i is $arg\n";
	1 while $delay--;
    }
}

sub start_thread {
    my $thread = shift;
    my $count = 10;
    while ($count--) {
	my(@args) = ($thread) x int(rand(10));
	print "$thread $count calling printargs @args\n";
	printargs($thread, @args);
    }
}

new Thread (\&start_thread, "A");
new Thread (\&start_thread, "B");
#new Thread (\&start_thread, "C");
#new Thread (\&start_thread, "D");
#new Thread (\&start_thread, "E");
#new Thread (\&start_thread, "F");

print "main: exiting\n";

--- NEW FILE: die.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread 'async';

$t = async {
    print "here\n";
    die "success";
    print "shouldn't get here\n";
};

sleep 1;
print "joining...\n";
eval { @r = $t->join; };
if ($@) {
    print "thread died with message: $@";
} else {
    print "thread failed to die successfully\n";
}

--- NEW FILE: README ---
See the README.threads in the main perl 5.004_xx development
distribution (x >= 50) for details of how to build and use this.
If all else fails, read on.

If your version of patch can't create a file from scratch, then you'll
need to create an empty thread.h manually first.  Perl itself will need
to be built with -DUSE_THREADS yet. If you're using MIT pthreads or
another threads package that needs pthread_init() to be called, then
add -DNEED_PTHREAD_INIT. If you're using a threads library that only
follows one of the old POSIX drafts, then you'll probably need to add
-DOLD_PTHREADS_API. I haven't tested -DOLD_PTHREADS_API properly yet
and I think you may still have to tweak a couple of the mutex calls
to follow the old API.

This extension is copyright Malcolm Beattie 1995-1997 and is freely
distributable under your choice of the GNU Public License or the
Artistic License (see the main perl distribution).

Malcolm Beattie
mbeattie at sable.ox.ac.uk

--- NEW FILE: io.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

sub counter {
$count = 10;
while ($count--) {
    sleep 1;
    print "ping $count\n";
}
}

sub reader {
    my $line;
    while ($line = <STDIN>) {
	print "reader: $line";
    }
    print "End of input in reader\n";
    return 0;
}

print <<'EOT';
This test starts up a thread to read and echo whatever is typed on
the keyboard/stdin, line by line, while the main thread counts down
to zero. The test stays running until both the main thread has
finished counting down and the I/O thread has seen end-of-file on
the terminal/stdin.
EOT

$r = new Thread \&counter;

&reader;

__END__


$count = 10;
while ($count--) {
    sleep 1;
    print "ping $count\n";
}

--- NEW FILE: typemap ---
Thread		T_XSCPTR

INPUT
T_XSCPTR
	STMT_START {
	    MAGIC *mg;
	    SV *sv = ($arg);

	    if (!sv_isobject(sv))
		croak(\"$var is not an object\");
	    sv = (SV*)SvRV(sv);
	    if (!SvRMAGICAL(sv) || !(mg = mg_find(sv, '~'))
		|| mg->mg_private != ${ntype}_MAGIC_SIGNATURE)
		croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\");
	    $var = ($type) SvPVX(mg->mg_obj);
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  \"XSUB ${func_name}: %p\\n\", $var));
	} STMT_END
T_IVREF
	if (SvROK($arg))
	    $var = ($type) SvIV((SV*)SvRV($arg));
	else
	    croak(\"$var is not a reference\")


--- NEW FILE: die2.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread 'async';

$t = async {
    sleep 1;
    print "here\n";
    die "success if preceded by 'thread died...'";
    print "shouldn't get here\n";
};

print "joining...\n";
@r = eval { $t->join; };
if ($@) {
    print "thread died with message: $@";
} else {
    print "thread failed to die successfully\n";
}

--- NEW FILE: join2.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;
sub foo {
    print "In foo with args: @_\n";
    return (7, 8, 9);
}

print "Starting thread\n";
$t = new Thread \&foo, qw(foo bar baz);
sleep 2;
print "Joining with $t\n";
@results = $t->join();
print "Joining returned @results\n";

--- NEW FILE: queue.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;
use Thread::Queue;

$q = new Thread::Queue;

sub reader {
    my $tid = Thread->self->tid;
    my $i = 0;
    while (1) {
	$i++;
	print "reader (tid $tid): waiting for element $i...\n";
	my $el = $q->dequeue;
	print "reader (tid $tid): dequeued element $i: value $el\n";
	select(undef, undef, undef, rand(2));
	if ($el == -1) {
	    # end marker
	    print "reader (tid $tid) returning\n";
	    return;
	}
    }
}

my $nthreads = 3;

for (my $i = 0; $i < $nthreads; $i++) {
    Thread->new(\&reader, $i);
}

for (my $i = 1; $i <= 10; $i++) {
    my $el = int(rand(100));
    select(undef, undef, undef, rand(2));
    print "writer: enqueuing value $el\n";
    $q->enqueue($el);
}

$q->enqueue((-1) x $nthreads); # one end marker for each thread

--- NEW FILE: Notes ---
Should cvcache be per CV (keyed by thread) or per thread (keyed by CV)?

Maybe ought to protect all SVs by a mutex for SvREFCNT_{dec,inc},
upgrades and so on. Then use SvMUTEX instead of CvMUTEX for CVs.
On the other hand, people shouldn't expect concurrent operations
on non-lexicals to be safe anyway.

Probably don't need to bother keeping track of CvOWNER on clones.

Either @_ needs to be made lexical or other arrangments need to be
made so that some globs (or just *_) are per-thread.

tokenbuf and buf probably ought to be global protected by a global lock.

--- NEW FILE: sync2.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$global = undef;

sub single_file : locked {
    my $who = shift;
    my $i;

    print "Uh oh: $who entered while locked by $global\n" if $global;
    $global = $who;
    print "[";
    for ($i = 0; $i < int(10 * rand); $i++) {
	print $who;
	select(undef, undef, undef, 0.1);
    }
    print "]";
    $global = undef;
}

sub start_a {
    my ($i, $j);
    for ($j = 0; $j < 10; $j++) {
	single_file("A");
	for ($i = 0; $i < int(10 * rand); $i++) {
	    print "a";
	    select(undef, undef, undef, 0.1);
	}
    }
}

sub start_b {
    my ($i, $j);
    for ($j = 0; $j < 10; $j++) {
	single_file("B");
	for ($i = 0; $i < int(10 * rand); $i++) {
	    print "b";
	    select(undef, undef, undef, 0.1);
	}
    }
}

sub start_c {
    my ($i, $j);
    for ($j = 0; $j < 10; $j++) {
	single_file("C");
	for ($i = 0; $i < int(10 * rand); $i++) {
	    print "c";
	    select(undef, undef, undef, 0.1);
	}
    }
}

$| = 1;
srand($$^$^T);

print <<'EOT';
Each pair of square brackets [...] should contain a repeated sequence of
a unique upper case letter. Lower case letters may appear randomly both
in and out of the brackets.
EOT
$foo = new Thread \&start_a;
$bar = new Thread \&start_b;
$baz = new Thread \&start_c;
print "\nmain: joining...\n";
#$foo->join;
#$bar->join;
#$baz->join;
print "\ndone\n";

--- NEW FILE: list.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread qw(async);
use Thread::Semaphore;

my $sem = Thread::Semaphore->new(0);

$nthreads = 4;

for (my $i = 0; $i < $nthreads; $i++) {
    async {
     	my $tid = Thread->self->tid;
	print "thread $tid started...\n";
	$sem->down;
	print "thread $tid finishing\n";
    };
}

print "main: started $nthreads threads\n";
sleep 2;

my @list = Thread->list;
printf "main: Thread->list returned %d threads\n", scalar(@list);

foreach my $t (@list) {
    print "inspecting thread $t...\n";
    print "...deref is $$t\n";
    print "...flags = ", $t->flags, "\n";
    print "...tid = ", $t->tid, "\n";
}
print "main thread telling workers to finish off...\n";
$sem->up($nthreads);

--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
WriteMakefile(
	NAME => 'Thread',
	VERSION_FROM => '../../lib/Thread.pm',
	MAN3PODS => {},
);


--- NEW FILE: join.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;
sub foo {
    print "In foo with args: @_\n";
    return (7, 8, 9);
}

print "Starting thread\n";
$t = new Thread \&foo, qw(foo bar baz);
print "Joining with $t\n";
@results = $t->join();
print "Joining returned ", scalar(@results), " values: @results\n";

--- NEW FILE: README.threads ---
NOTE: This documentation describes the style of threading that was
available in Perl 5.005.  Perl 5.6.0 introduced the early beginnings of
interpreter-based threads support, also known as ithreads, and in Perl
5.8.0 the interpeter threads became available from perl level through
the threads and threads::shared modules (in Perl 5.6 ithreads are
available only internally and to XS extension builders, and used
by the Win32 port for emulating fork()). As of Perl 5.8.0, ithreads has
become the standard threading model for Perl.

If you really want the older support for threads described below,
it is enabled with:

    sh Configure -Dusethreads -Duse5005threads

Be warned that the old 5.005 implementation of threads is known
to be quite buggy, and unmaintained, which means that the bugs
are there to stay.  (We are not mean by not fixing the bugs:
the bugs are just really, really, really hard to fix.  Honest.)

The rest of this document only applies to the use5005threads style of
threads, and the comments on what works on which platform are highly
obsolete and preserved here for archaeology buffs only.  The
architecture specific hints files do all the necessary option
tweaking automatically during Configure, both for the 5.005 threads
and for the new interpreter threads.

---------------------------------------------------------------------------

Support for threading is still in the highly experimental stages.  There
are known race conditions that show up under high contention on SMP
machines.  Internal implementation is still subject to changes.
It is not recommended for production use at this time.

---------------------------------------------------------------------------

Building

If your system is in the following list you should be able to just:

    ./Configure -Dusethreads -Duse5005threads -des
    make

and ignore the rest of this "Building" section.  If not, continue
from the "Problems" section.

	* Linux 2.* (with the LinuxThreads library installed:
	  that's the linuxthreads and linuxthreads-devel RPMs
	  for RedHat)

	* Tru64 UNIX (formerly Digital UNIX formerly DEC OSF/1)
	  (see additional note below)

	* Solaris 2.* for recentish x (2.5 is OK)

	* IRIX 6.2 or newer. 6.2 will require a few OS patches.
	  IMPORTANT: Without patch 2401 (or its replacement),
	  a kernel bug in IRIX 6.2 will cause your machine to
	  panic and crash when running threaded perl.
	  IRIX 6.3 and up should be OK. See lower down for patch details.

	* AIX 4.1.5 or newer.

	* FreeBSD 2.2.8 or newer.

	* OpenBSD

	* NeXTstep, OpenStep

	* OS/2

	* DOS DJGPP

	* VM/ESA

---------------------------------------------------------------------------

Problems

If the simple way doesn't work or you are using another platform which
you believe supports POSIX.1c threads then read on.  Additional
information may be in a platform-specific "hints" file in the hints/
subdirectory.

On platforms that use Configure to build perl, omit the -d from your
./Configure arguments. For example, use:

    ./Configure -Dusethreads -Duse5005threads

When Configure prompts you for ccflags, insert any other arguments in
there that your compiler needs to use POSIX threads (-D_REENTRANT,
-pthreads, -threads, -pthread, -thread, are good guesses). When
Configure prompts you for linking flags, include any flags required
for threading (usually nothing special is required here).  Finally,
when Configure prompts you for libraries, include any necessary
libraries (e.g. -lpthread).  Pay attention to the order of libraries.
It is probably necessary to specify your threading library *before*
your standard C library, e.g.  it might be necessary to have -lpthread
-lc, instead of -lc -lpthread.  You may also need to use -lc_r instead
of -lc.

Once you have specified all your compiler flags, you can have Configure
accept all the defaults for the remainder of the session by typing  &-d
at any Configure prompt.

Some additional notes (some of these may be obsolete now, other items
may be handled automatically):

For Digital Unix 4.x:
    Add -pthread to ccflags
    Add -pthread to ldflags
    Add -lpthread -lc_r to lddlflags

    For some reason, the extra includes for pthreads make Digital UNIX
    complain fatally about the sbrk() declaration in perl's malloc.c
    so use the native malloc, e.g.  sh Configure -Uusemymalloc, or
    manually edit your config.sh as follows:
	Change usemymalloc to n
	Zap mallocobj and mallocsrc (foo='')
	Change d_mymalloc to undef

For Digital Unix 3.x (Formerly DEC OSF/1):
    Add -DOLD_PTHREADS_API to ccflags
    If compiling with the GNU cc compiler, remove -threads from ccflags

    (The following should be done automatically if you call Configure
      with the -Dusethreads option).
    Add -lpthread -lmach -lc_r to libs (in the order specified).

For IRIX:
    (This should all be done automatically by the hint file).
    Add -lpthread to libs
    For IRIX 6.2, you have to have the following patches installed:
	1404 Irix 6.2 Posix 1003.1b man pages
	1645 IRIX 6.2 & 6.3 POSIX header file updates
	2000 Irix 6.2 Posix 1003.1b support modules
	2254 Pthread library fixes
	2401 6.2 all platform kernel rollup
    IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will
    cause your machine to panic and crash when running threaded perl.
    IRIX 6.3 and up should be OK.

    For IRIX 6.3 and 6.4 the pthreads should work out of the box.
    Thanks to Hannu Napari <Hannu.Napari at hut.fi> for the IRIX
    pthreads patches information.

For AIX:
    (This should all be done automatically by the hint file).
    Change cc to xlc_r or cc_r.
    Add -DNEED_PTHREAD_INIT to ccflags and cppflags
    Add -lc_r to libswanted
    Change -lc in lddflags to be -lpthread -lc_r -lc

For Win32:
    See README.win32, and the notes at the beginning of win32/Makefile
    or win32/makefile.mk.

Now you can do a
    make

When you succeed in compiling and testing ("make test" after your
build) a threaded Perl in a platform previously unknown to support
threaded perl, please let perlbug at perl.com know about your victory.
Explain what you did in painful detail.

---------------------------------------------------------------------------

O/S specific bugs

Irix 6.2:  See the Irix warning above.

LinuxThreads 0.5 has a bug which can cause file descriptor 0 to be
closed after a fork() leading to many strange symptoms. Version 0.6
has this fixed but the following patch can be applied to 0.5 for now:

----------------------------- cut here -----------------------------
--- linuxthreads-0.5/pthread.c.ORI	Mon Oct  6 13:55:50 1997
+++ linuxthreads-0.5/pthread.c	Mon Oct  6 13:57:24 1997
@@ -312,8 +312,10 @@
   free(pthread_manager_thread_bos);
   pthread_manager_thread_bos = pthread_manager_thread_tos = NULL;
   /* Close the two ends of the pipe */
-  close(pthread_manager_request);
-  close(pthread_manager_reader);
+  if (pthread_manager_request >= 0) {
+    close(pthread_manager_request);
+    close(pthread_manager_reader);
+  }
   pthread_manager_request = pthread_manager_reader = -1;
   /* Update the pid of the main thread */
   self->p_pid = getpid();
----------------------------- cut here -----------------------------


Building the Thread extension

The Thread extension is now part of the main perl distribution tree.
If you did Configure -Dusethreads -Duse5005threads then it will have been
added to the list of extensions automatically.

You can try some of the tests with
    cd ext/Thread
    perl create.t
    perl join.t
    perl lock.t
    perl io.t
etc.
The io one leaves a thread reading from the keyboard on stdin so
as the ping messages appear you can type lines and see them echoed.

Try running the main perl test suite too. There are known
failures for some of the DBM/DB extensions (if their underlying
libraries were not compiled to be thread-aware).

---------------------------------------------------------------------------

Bugs

* FAKE_THREADS should produce a working perl but the Thread
extension won't build with it yet.  (FAKE_THREADS has not been
tested at all in recent times.)

* There may still be races where bugs show up under contention.

---------------------------------------------------------------------------

Debugging

Use the -DS command-line option to turn on debugging of the
multi-threading code. Under Linux, that also turns on a quick
hack I did to grab a bit of extra information from segfaults.
If you have a fancier gdb/threads setup than I do then you'll
have to delete the lines in perl.c which say
    #if defined(DEBUGGING) && defined(USE_5005THREADS) && defined(__linux__)
        DEBUG_S(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
    #endif

---------------------------------------------------------------------------

Background

Some old globals (e.g. stack_sp, op) and some old per-interpreter
variables (e.g. tmps_stack, cxstack) move into struct thread.
All fields of struct thread which derived from original perl
variables have names of the form Tfoo. For example, stack_sp becomes
the field Tstack_sp of struct thread. For those fields which moved
from original perl, thread.h does
    #define foo (thr->Tfoo)
This means that all functions in perl which need to use one of these
fields need an (automatic) variable thr which points at the current
thread's struct thread. For pp_foo functions, it is passed around as
an argument, for other functions they do
    dTHR;
which declares and initialises thr from thread-specific data
via pthread_getspecific. If a function fails to compile with an
error about "no such variable thr", it probably just needs a dTHR
at the top.


Fake threads

For FAKE_THREADS, thr is a global variable and perl schedules threads
by altering thr in between appropriate ops. The next and prev fields
of struct thread keep all fake threads on a doubly linked list and
the next_run and prev_run fields keep all runnable threads on a
doubly linked list. Mutexes are stubs for FAKE_THREADS. Condition
variables are implemented as a list of waiting threads.


Mutexes and condition variables

The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and
COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}.

A mutex is only required to be a simple, fast mutex (e.g. it does not
have to be recursive). It is only ever held across very short pieces
of code. Condition variables are only ever signalled/broadcast while
their associated mutex is held. (This constraint simplifies the
implementation of condition variables in certain porting situations.)
For POSIX threads, perl mutexes and condition variables correspond to
POSIX ones.  For FAKE_THREADS, mutexes are stubs and condition variables
are implemented as lists of waiting threads. For FAKE_THREADS, a thread
waits on a condition variable by removing itself from the runnable
list, calling SCHEDULE to change thr to the next appropriate
runnable thread and returning op (i.e. the new threads next op).
This means that fake threads can only block while in PP code.
A PP function which contains a COND_WAIT must be prepared to
handle such restarts and can use the field "private" of struct
thread to record its state. For fake threads, COND_SIGNAL and
COND_BROADCAST work by putting back all the threads on the
condition variables list into the run queue. Note that a mutex
must *not* be held while returning from a PP function.

Perl locks and condition variables are both implemented as a
condpair_t structure, containing a mutex, an "owner" condition
variable, an owner thread field and another condition variable).
The structure is attached by 'm' magic to any SV. pp_lock locks
such an object by waiting on the ownercond condition variable until
the owner field is zero and then setting the owner field to its own
thread pointer. The lock is semantically recursive so if the owner
field already matches the current thread then pp_lock returns
straight away. If the owner field has to be filled in then
unlock_condpair is queued as an end-of-block destructor and
that function zeroes out the owner field and signals the ownercond
condition variable, thus waking up any other thread that wants to
lock it. When used as a condition variable, the condpair is locked
(involving the above wait-for-ownership and setting the owner field)
and the spare condition variable field is used for waiting on.


Thread states


              $t->join
R_JOINABLE ---------------------> R_JOINED >----\
    |      \  pthread_join(t)         |  ^      |
    |       \                         |  | join | pthread_join
    |        \                        |  |      |
    |         \                       |  \------/
    |          \                      |
    |           \                     |
    |  $t->detach\ pthread_detach     |
    |            _\|                  |
ends|             R_DETACHED     ends | unlink
    |                       \         |
    |                   ends \ unlink |
    |                         \       |
    |                          \      |
    |                           \     |
    |                            \    |
    |                             \   |
    V    join          detach     _\| V
ZOMBIE ----------------------------> DEAD
       pthread_join   pthread_detach
       and unlink     and unlink



Malcolm Beattie
mbeattie at sable.ox.ac.uk
Last updated: 27 November 1997

Configure-related info updated 16 July 1998 by
Andy Dougherty <doughera at lafayette.edu>

Other minor updates 10 Feb 1999 by
Gurusamy Sarathy

More platforms added 26 Jul 1999 by
Jarkko Hietaniemi

--- NEW FILE: Thread.xs ---
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* Magic signature for Thread's mg_private is "Th" */ 
#define Thread_MAGIC_SIGNATURE 0x5468

#ifdef __cplusplus
#ifdef I_UNISTD
#include <unistd.h>
#endif
#endif
#include <fcntl.h>
                        
static int sig_pipe[2];
            
#ifndef THREAD_RET_TYPE
#define THREAD_RET_TYPE void *
#define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x)
#endif

static void
remove_thread(pTHX_ Thread t)
{
#ifdef USE_5005THREADS
    DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
				   "%p: remove_thread %p\n", thr, t)));
    MUTEX_LOCK(&PL_threads_mutex);
    MUTEX_DESTROY(&t->mutex);
    PL_nthreads--;
    t->prev->next = t->next;
    t->next->prev = t->prev;
    SvREFCNT_dec(t->oursv);
    COND_BROADCAST(&PL_nthreads_cond);
    MUTEX_UNLOCK(&PL_threads_mutex);
#endif
}

static THREAD_RET_TYPE
threadstart(void *arg)
{
#ifdef USE_5005THREADS
#ifdef FAKE_THREADS
    Thread savethread = thr;
    LOGOP myop;
    dSP;
    I32 oldscope = PL_scopestack_ix;
    I32 retval;
    AV *av;
    int i;

    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
			  thr, SvPEEK(TOPs)));
    thr = (Thread) arg;
    savemark = TOPMARK;
    thr->prev = thr->prev_run = savethread;
    thr->next = savethread->next;
    thr->next_run = savethread->next_run;
    savethread->next = savethread->next_run = thr;
    thr->wait_queue = 0;
    thr->private = 0;

    /* Now duplicate most of perl_call_sv but with a few twists */
    PL_op = (OP*)&myop;
    Zero(PL_op, 1, LOGOP);
    myop.op_flags = OPf_STACKED;
    myop.op_next = Nullop;
    myop.op_flags |= OPf_KNOW;
    myop.op_flags |= OPf_WANT_LIST;
    PL_op = pp_entersub(ARGS);
    DEBUG_S(if (!PL_op)
	    PerlIO_printf(Perl_debug_log, "thread starts at Nullop\n"));
    /*
     * When this thread is next scheduled, we start in the right
     * place. When the thread runs off the end of the sub, perl.c
     * handles things, using savemark to figure out how much of the
     * stack is the return value for any join.
     */
    thr = savethread;		/* back to the old thread */
    return 0;
#else
    Thread thr = (Thread) arg;
    dSP;
    I32 oldmark = TOPMARK;
    I32 retval;
    SV *sv;
    AV *av;
    int i;

#if defined(MULTIPLICITY)
    PERL_SET_INTERP(thr->interp);
#endif

    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n",
			  thr));

    /*
     * Wait until our creator releases us. If we didn't do this, then
     * it would be potentially possible for out thread to carry on and
     * do stuff before our creator fills in our "self" field. For example,
     * if we went and created another thread which tried to JOIN with us,
     * then we'd be in a mess.
     */
    MUTEX_LOCK(&thr->mutex);
    MUTEX_UNLOCK(&thr->mutex);

    /*
     * It's safe to wait until now to set the thread-specific pointer
     * from our pthread_t structure to our struct perl_thread, since
     * we're the only thread who can get at it anyway.
     */
    PERL_SET_THX(thr);

    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
			  thr, SvPEEK(TOPs)));

    av = newAV();
    sv = POPs;
    PUTBACK;
    ENTER;
    SAVETMPS;
    perl_call_sv(sv, G_ARRAY|G_EVAL);
    SPAGAIN;
    retval = SP - (PL_stack_base + oldmark);
    SP = PL_stack_base + oldmark + 1;
    if (SvCUR(thr->errsv)) {
	MUTEX_LOCK(&thr->mutex);
	thr->flags |= THRf_DID_DIE;
	MUTEX_UNLOCK(&thr->mutex);
	av_store(av, 0, &PL_sv_no);
	av_store(av, 1, newSVsv(thr->errsv));
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p died: %s\n",
			      thr, SvPV(thr->errsv, PL_na)));
    }
    else {
	DEBUG_S(STMT_START {
	    for (i = 1; i <= retval; i++) {
		PerlIO_printf(Perl_debug_log, "%p return[%d] = %s\n",
				thr, i, SvPEEK(SP[i - 1]));
	    }
	} STMT_END);
	av_store(av, 0, &PL_sv_yes);
	for (i = 1; i <= retval; i++, SP++)
	    sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP));
    }
    FREETMPS;
    LEAVE;

#if 0    
    /* removed for debug */
    SvREFCNT_dec(PL_curstack);
#endif
    SvREFCNT_dec(thr->cvcache);
    SvREFCNT_dec(thr->threadsv);
    SvREFCNT_dec(thr->specific);
    SvREFCNT_dec(thr->errsv);

    /*Safefree(cxstack);*/
    while (PL_curstackinfo->si_next)
	PL_curstackinfo = PL_curstackinfo->si_next;
    while (PL_curstackinfo) {
	PERL_SI *p = PL_curstackinfo->si_prev;
	SvREFCNT_dec(PL_curstackinfo->si_stack);
	Safefree(PL_curstackinfo->si_cxstack);
	Safefree(PL_curstackinfo);
	PL_curstackinfo = p;
    }    
    Safefree(PL_markstack);
    Safefree(PL_scopestack);
    Safefree(PL_savestack);
    Safefree(PL_retstack);
    Safefree(PL_tmps_stack);
    SvREFCNT_dec(PL_ofs_sv);

    SvREFCNT_dec(PL_rs);
    SvREFCNT_dec(PL_statname);
    SvREFCNT_dec(PL_errors);
    Safefree(PL_screamfirst);
    Safefree(PL_screamnext);
    Safefree(PL_reg_start_tmp);
    SvREFCNT_dec(PL_lastscream);
    SvREFCNT_dec(PL_defoutgv);
    Safefree(PL_reg_poscache);

    MUTEX_LOCK(&thr->mutex);
    thr->thr_done = 1;
    DEBUG_S(PerlIO_printf(Perl_debug_log,
			  "%p: threadstart finishing: state is %u\n",
			  thr, ThrSTATE(thr)));
    switch (ThrSTATE(thr)) {
    case THRf_R_JOINABLE:
	ThrSETSTATE(thr, THRf_ZOMBIE);
	MUTEX_UNLOCK(&thr->mutex);
	DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "%p: R_JOINABLE thread finished\n", thr));
	break;
    case THRf_R_JOINED:
	ThrSETSTATE(thr, THRf_DEAD);
	MUTEX_UNLOCK(&thr->mutex);
	remove_thread(aTHX_ thr);
	DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "%p: R_JOINED thread finished\n", thr));
	break;
    case THRf_R_DETACHED:
	ThrSETSTATE(thr, THRf_DEAD);
	MUTEX_UNLOCK(&thr->mutex);
	SvREFCNT_dec(av);
	DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "%p: DETACHED thread finished\n", thr));
	remove_thread(aTHX_ thr);	/* This might trigger main thread to finish */
	break;
    default:
	MUTEX_UNLOCK(&thr->mutex);
	croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
	/* NOTREACHED */
    }
    return THREAD_RET_CAST(av);	/* Available for anyone to join with */
					/* us unless we're detached, in which */
					/* case noone sees the value anyway. */
#endif    
#else
    return THREAD_RET_CAST(NULL);
#endif
}

static SV *
newthread (pTHX_ SV *startsv, AV *initargs, char *classname)
{
#ifdef USE_5005THREADS
    dSP;
    Thread savethread;
    int i;
    SV *sv;
    int err;
#ifndef THREAD_CREATE
    static pthread_attr_t attr;
    static int attr_inited = 0;
    sigset_t fullmask, oldmask;
    static int attr_joinable = PTHREAD_CREATE_JOINABLE;
#endif

    if (ckWARN(WARN_DEPRECATED))	
        Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
		    "5.005 threads are deprecated");
    savethread = thr;
    thr = new_struct_thread(thr);
    /* temporarily pretend to be the child thread in case the
     * XPUSHs() below want to grow the child's stack.  This is
     * safe, since the other thread is not yet created, and we
     * are the only ones who know about it */
    PERL_SET_THX(thr);
    SPAGAIN;
    DEBUG_S(PerlIO_printf(Perl_debug_log,
			  "%p: newthread (%p), tid is %u, preparing stack\n",
			  savethread, thr, thr->tid));
    /* The following pushes the arg list and startsv onto the *new* stack */
    PUSHMARK(SP);
    /* Could easily speed up the following greatly */
    for (i = 0; i <= AvFILL(initargs); i++)
	XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
    XPUSHs(SvREFCNT_inc(startsv));
    PUTBACK;

    /* On your marks... */
    PERL_SET_THX(savethread);
    MUTEX_LOCK(&thr->mutex);

#ifdef THREAD_CREATE
    err = THREAD_CREATE(thr, threadstart);
#else    
    /* Get set...  */
    sigfillset(&fullmask);
    if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
	croak("panic: sigprocmask");
    err = 0;
    if (!attr_inited) {
	attr_inited = 1;
	err = pthread_attr_init(&attr);
#  ifdef THREAD_CREATE_NEEDS_STACK
       if (err == 0)
            err = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
       if (err)
           croak("panic: pthread_attr_setstacksize failed");
#  endif
#  ifdef PTHREAD_ATTR_SETDETACHSTATE
	if (err == 0)
	    err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
       if (err)
           croak("panic: pthread_attr_setdetachstate failed");
#  else
	croak("panic: can't pthread_attr_setdetachstate");
#  endif
    }
    if (err == 0)
	err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr);
#endif

    if (err) {
	MUTEX_UNLOCK(&thr->mutex);
        DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "%p: create of %p failed %d\n",
			      savethread, thr, err));
	/* Thread creation failed--clean up */
	SvREFCNT_dec(thr->cvcache);
	remove_thread(aTHX_ thr);
	for (i = 0; i <= AvFILL(initargs); i++)
	    SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
	SvREFCNT_dec(startsv);
	return NULL;
    }

#ifdef THREAD_POST_CREATE
    THREAD_POST_CREATE(thr);
#else
    if (sigprocmask(SIG_SETMASK, &oldmask, 0))
	croak("panic: sigprocmask");
#endif

    sv = newSViv(thr->tid);
    sv_magic(sv, thr->oursv, '~', 0, 0);
    SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
    sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));

    /* Go */
    MUTEX_UNLOCK(&thr->mutex);

    return sv;
#else
#  ifdef USE_ITHREADS
    croak("This perl was built for \"ithreads\", which currently does not support Thread.pm.\n"
	  "Run \"perldoc Thread\" for more information");
#  else
    croak("This perl was not built with support for 5.005-style threads.\n"
	  "Run \"perldoc Thread\" for more information");
#  endif
    return &PL_sv_undef;
#endif
}

static Signal_t handle_thread_signal (int sig);

static Signal_t
handle_thread_signal(int sig)
{
    unsigned char c = (unsigned char) sig;
    dTHX;
    /*
     * We're not really allowed to call fprintf in a signal handler
     * so don't be surprised if this isn't robust while debugging
     * with -DL.
     */
    DEBUG_S(PerlIO_printf(Perl_debug_log,
	    "handle_thread_signal: got signal %d\n", sig));
    write(sig_pipe[1], &c, 1);
}

MODULE = Thread		PACKAGE = Thread
PROTOTYPES: DISABLE

void
new(classname, startsv, ...)
	char *		classname
	SV *		startsv
	AV *		av = av_make(items - 2, &ST(2));
    PPCODE:
	XPUSHs(sv_2mortal(newthread(aTHX_ startsv, av, classname)));

void
join(t)
	Thread	t
    PREINIT:
#ifdef USE_5005THREADS
	AV *	av;
	int	i;
#endif
    PPCODE:
#ifdef USE_5005THREADS
	if (t == thr)
	    croak("Attempt to join self");
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n",
			      thr, t, ThrSTATE(t)));
    	MUTEX_LOCK(&t->mutex);
	switch (ThrSTATE(t)) {
	case THRf_R_JOINABLE:
	case THRf_R_JOINED:
	    ThrSETSTATE(t, THRf_R_JOINED);
	    MUTEX_UNLOCK(&t->mutex);
	    break;
	case THRf_ZOMBIE:
	    ThrSETSTATE(t, THRf_DEAD);
	    MUTEX_UNLOCK(&t->mutex);
	    remove_thread(aTHX_ t);
	    break;
	default:
	    MUTEX_UNLOCK(&t->mutex);
	    croak("can't join with thread");
	    /* NOTREACHED */
	}
	JOIN(t, &av);

	sv_2mortal((SV*)av);

	if (SvTRUE(*av_fetch(av, 0, FALSE))) {
	    /* Could easily speed up the following if necessary */
	    for (i = 1; i <= AvFILL(av); i++)
		XPUSHs(*av_fetch(av, i, FALSE));
	}
	else {
	    STRLEN n_a;
	    char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a);
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  "%p: join propagating die message: %s\n",
				  thr, mess));
	    croak(mess);
	}
#endif

void
detach(t)
	Thread	t
    CODE:
#ifdef USE_5005THREADS
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n",
			      thr, t, ThrSTATE(t)));
    	MUTEX_LOCK(&t->mutex);
	switch (ThrSTATE(t)) {
	case THRf_R_JOINABLE:
	    ThrSETSTATE(t, THRf_R_DETACHED);
	    /* fall through */
	case THRf_R_DETACHED:
	    DETACH(t);
	    MUTEX_UNLOCK(&t->mutex);
	    break;
	case THRf_ZOMBIE:
	    ThrSETSTATE(t, THRf_DEAD);
	    DETACH(t);
	    MUTEX_UNLOCK(&t->mutex);
	    remove_thread(aTHX_ t);
	    break;
	default:
	    MUTEX_UNLOCK(&t->mutex);
	    croak("can't detach thread");
	    /* NOTREACHED */
	}
#endif

void
equal(t1, t2)
	Thread	t1
	Thread	t2
    PPCODE:
	PUSHs((t1 == t2) ? &PL_sv_yes : &PL_sv_no);

void
flags(t)
	Thread	t
    PPCODE:
#ifdef USE_5005THREADS
	PUSHs(sv_2mortal(newSViv(t->flags)));
#endif

void
done(t)
	Thread	t
    PPCODE:
#ifdef USE_5005THREADS
	PUSHs(t->thr_done ? &PL_sv_yes : &PL_sv_no);
#endif

void
self(classname)
	char *	classname
    PREINIT:
#ifdef USE_5005THREADS
	SV *sv;
#endif
    PPCODE:        
#ifdef USE_5005THREADS
	sv = newSViv(thr->tid);
	sv_magic(sv, thr->oursv, '~', 0, 0);
	SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
	PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv),
				  gv_stashpv(classname, TRUE))));
#endif

U32
tid(t)
	Thread	t
    CODE:
#ifdef USE_5005THREADS
    	MUTEX_LOCK(&t->mutex);
	RETVAL = t->tid;
    	MUTEX_UNLOCK(&t->mutex);
#else 
	RETVAL = 0;
#endif
    OUTPUT:
	RETVAL

void
DESTROY(t)
	SV *	t
    PPCODE:
	PUSHs(t ? &PL_sv_yes : &PL_sv_no);

void
yield()
    CODE:
{
#ifdef USE_5005THREADS
	YIELD;
#endif
}

void
cond_wait(sv)
	SV *	sv
PREINIT:
#ifdef USE_5005THREADS
	MAGIC *	mg;
#endif
CODE:                       
#ifdef USE_5005THREADS
	if (SvROK(sv))
	    sv = SvRV(sv);

	mg = condpair_magic(sv);
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_wait %p\n", thr, sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_wait for lock that we don't own\n");
	}
	MgOWNER(mg) = 0;
	COND_SIGNAL(MgOWNERCONDP(mg));
	COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
	while (MgOWNER(mg))
	    COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
	MgOWNER(mg) = thr;
	MUTEX_UNLOCK(MgMUTEXP(mg));
#endif

void
cond_signal(sv)
	SV *	sv
PREINIT:
#ifdef USE_5005THREADS
	MAGIC *	mg;
#endif
CODE:
#ifdef USE_5005THREADS
	if (SvROK(sv))
	    sv = SvRV(sv);

	mg = condpair_magic(sv);
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_signal %p\n",thr,sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_signal for lock that we don't own\n");
	}
	COND_SIGNAL(MgCONDP(mg));
	MUTEX_UNLOCK(MgMUTEXP(mg));
#endif

void
cond_broadcast(sv)
	SV *	sv
PREINIT:
#ifdef USE_5005THREADS
	MAGIC *	mg;
#endif
CODE: 
#ifdef USE_5005THREADS
	if (SvROK(sv))
	    sv = SvRV(sv);

	mg = condpair_magic(sv);
	DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_broadcast %p\n",
			      thr, sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_broadcast for lock that we don't own\n");
	}
	COND_BROADCAST(MgCONDP(mg));
	MUTEX_UNLOCK(MgMUTEXP(mg));
#endif

void
list(classname)
	char *	classname
    PREINIT:
#ifdef USE_5005THREADS
	Thread	t;
	AV *	av;
	SV **	svp;
	int	n = 0;
#endif
    PPCODE:
#ifdef USE_5005THREADS
	av = newAV();
	/*
	 * Iterate until we have enough dynamic storage for all threads.
	 * We mustn't do any allocation while holding threads_mutex though.
	 */
	MUTEX_LOCK(&PL_threads_mutex);
	do {
	    n = PL_nthreads;
	    MUTEX_UNLOCK(&PL_threads_mutex);
	    if (AvFILL(av) < n - 1) {
		int i = AvFILL(av);
		for (i = AvFILL(av); i < n - 1; i++) {
		    SV *sv = newSViv(0);	/* fill in tid later */
		    sv_magic(sv, 0, '~', 0, 0);	/* fill in other magic later */
		    av_push(av, sv_bless(newRV_noinc(sv),
					 gv_stashpv(classname, TRUE)));
	
		}
	    }
	    MUTEX_LOCK(&PL_threads_mutex);
	} while (n < PL_nthreads);
	n = PL_nthreads;	/* Get the final correct value */

	/*
	 * At this point, there's enough room to fill in av.
	 * Note that we are holding threads_mutex so the list
	 * won't change out from under us but all the remaining
	 * processing is "fast" (no blocking, malloc etc.)
	 */
	t = thr;
	svp = AvARRAY(av);
	do {
	    SV *sv = (SV*)SvRV(*svp);
	    sv_setiv(sv, t->tid);
	    SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
	    SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
	    SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
	    t = t->next;
	    svp++;
	} while (t != thr);
	/*  */
	MUTEX_UNLOCK(&PL_threads_mutex);
	/* Truncate any unneeded slots in av */
	av_fill(av, n - 1);
	/* Finally, push all the new objects onto the stack and drop av */
	EXTEND(SP, n);
	for (svp = AvARRAY(av); n > 0; n--, svp++)
	    PUSHs(*svp);
	(void)sv_2mortal((SV*)av);
#endif


MODULE = Thread		PACKAGE = Thread::Signal

void
kill_sighandler_thread()
    PPCODE:
	write(sig_pipe[1], "\0", 1);
	PUSHs(&PL_sv_yes);

void
init_thread_signals()
    PPCODE:
	PL_sighandlerp = handle_thread_signal;
	if (pipe(sig_pipe) == -1)
	    XSRETURN_UNDEF;
	PUSHs(&PL_sv_yes);

void
await_signal()
    PREINIT:
	unsigned char c;
	SSize_t ret;
    CODE:
	do {
	    ret = read(sig_pipe[0], &c, 1);
	} while (ret == -1 && errno == EINTR);
	if (ret == -1)
	    croak("panic: await_signal");
	ST(0) = sv_newmortal();
	if (ret)
	    sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no);
	DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "await_signal returning %s\n", SvPEEK(ST(0))));

MODULE = Thread		PACKAGE = Thread::Specific

void
data(classname = "Thread::Specific")
	char *	classname
    PPCODE:
#ifdef USE_5005THREADS
	if (AvFILL(thr->specific) == -1) {
	    GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV);
	    av_store(thr->specific, 0, newRV((SV*)GvHV(gv)));
	}
	XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE)));
#endif

--- NEW FILE: unsync3.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$| = 1;

srand($$^$^T);

sub whoami {
    my $thread = shift;
    print $thread;
}

sub uppercase {
    my $count = 100;
    while ($count--) {
	my $i = int(rand(1000));
	1 while $i--;
	print "A";
	$i = int(rand(1000));
	1 while $i--;
	whoami("B");
    }
}
	
sub lowercase {
    my $count = 100;
    while ($count--) {
	my $i = int(rand(1000));
	1 while $i--;
	print "x";
	$i = int(rand(1000));
	1 while $i--;
	whoami("y");
    }
}
	
sub numbers {
    my $count = 100;
    while ($count--) {
	my $i = int(rand(1000));
	1 while $i--;
	print 1;
	$i = int(rand(1000));
	1 while $i--;
	whoami(2);
    }
}
	
new Thread \&numbers;
new Thread \&uppercase;
new Thread \&lowercase;

--- NEW FILE: create.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread 'async';
use Config;
use Tie::Hash;

sub start_here {
    my $i;
    print "In start_here with args: @_\n";
    for ($i = 1; $i <= 5; $i++) {
	print "start_here: $i\n";
	sleep 1;
    }
}

async {
    tie my(%h), 'Tie::StdHash';
    %h = %Config;
    print "running on $h{archname}\n";
};

print "Starting new thread now\n";
$t = new Thread \&start_here, qw(foo bar baz);
print "Started thread $t\n";
for ($count = 1; $count <= 5; $count++) {
    print "main: $count\n";
    sleep 1;
}

--- NEW FILE: lock.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$level = 0;

sub worker
{
    my $num = shift;
    my $i;
    print "thread $num starting\n";
    for ($i = 1; $i <= 20; $i++) {
	print "thread $num iteration $i\n";
	select(undef, undef, undef, rand(10)/100);
	{
	    lock($lock);
	    warn "thread $num saw non-zero level = $level\n" if $level;
	    $level++;
	    print "thread $num has lock\n";
	    select(undef, undef, undef, rand(10)/100);
	    $level--;
	}
	print "thread $num released lock\n";
    }
}

for ($t = 1; $t <= 5; $t++) {
    new Thread \&worker, $t;
}

--- NEW FILE: sync.tx ---
BEGIN {
    eval { require Config; import Config };
    if ($@) {
	print "1..0 # Skip: no Config\n";
	exit(0);
    }
}

use Thread;

$level = 0;

sub single_file : locked {
    my $arg = shift;
    $level++;
    print "Level $level for $arg\n";
    print "(something is wrong)\n" if $level < 0 || $level > 1;
    sleep 1;
    $level--;
    print "Back to level $level\n";
}

sub start_bar {
    my $i;
    print "start bar\n";
    for $i (1..3) {
	print "bar $i\n";
	single_file("bar $i");
	sleep 1 if rand > 0.5;
    }
    print "end bar\n";
    return 1;
}

sub start_foo {
    my $i;
    print "start foo\n";
    for $i (1..3) {
	print "foo $i\n";
	single_file("foo $i");
	sleep 1 if rand > 0.5;
    }
    print "end foo\n";
    return 1;
}

sub start_baz {
    my $i;
    print "start baz\n";
    for $i (1..3) {
	print "baz $i\n";
	single_file("baz $i");
	sleep 1 if rand > 0.5;
    }
    print "end baz\n";
    return 1;
}

$| = 1;
srand($$^$^T);

$foo = new Thread \&start_foo;
$bar = new Thread \&start_bar;
$baz = new Thread \&start_baz;
$foo->join();
$bar->join();
$baz->join();
print "main: threads finished, exiting\n";




More information about the dslinux-commit mailing list