dslinux/user/perl/ext/threads Changes Makefile.PL README threads.pm threads.xs typemap
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:27:01 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/threads
In directory antilope:/tmp/cvs-serv7729/ext/threads
Added Files:
Changes Makefile.PL README threads.pm threads.xs typemap
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'threads',
'VERSION_FROM' => 'threads.pm', # finds $VERSION
'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'threads.pm', # retrieve abstract from module
AUTHOR => 'Artur Bergman <artur at contiller.se>') : ()),
'MAN3PODS' => {}, # Pods will be built by installman
'LIBS' => [''], # e.g., '-lm'
'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
# Insert -I. if you add *.h files later:
# 'INC' => '', # e.g., '-I/usr/include/other'
# Un-comment this if you add C files to link with later:
# 'OBJECT' => '$(O_FILES)', # link all the C files too
# ext/threads/shared is a completely different module. Don't
# recurse into it.
'NORECURS' => 1,
# Bug in MakeMaker continues to put ext/threads/shared into DIR
# even if we said NORECURS. Remove when fixed.
'DIR' => [],
);
--- NEW FILE: threads.xs ---
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef USE_ITHREADS
#ifdef WIN32
#include <windows.h>
#include <win32thread.h>
#else
#ifdef OS2
typedef perl_os_thread pthread_t;
#else
#include <pthread.h>
#endif
#include <thread.h>
#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
#ifdef OLD_PTHREADS_API
#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
#else
#define PERL_THREAD_DETACH(t) pthread_detach((t))
#endif /* OLD_PTHREADS_API */
#endif
/* Values for 'state' member */
#define PERL_ITHR_JOINABLE 0
#define PERL_ITHR_DETACHED 1
#define PERL_ITHR_FINISHED 4
#define PERL_ITHR_JOINED 2
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 */
perl_mutex mutex; /* Mutex for updating things in this struct */
I32 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 */
SV* params; /* Args to pass function */
#ifdef WIN32
DWORD thr; /* OS's idea if thread id */
HANDLE handle; /* OS's waitable handle */
#else
pthread_t thr; /* OS's handle for the thread */
#endif
} ithread;
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 perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
I32 tid_counter = 0;
I32 known_threads = 0;
I32 active_threads = 0;
void Perl_ithread_set (pTHX_ ithread* thread)
{
SV* thread_sv = newSViv(PTR2IV(thread));
if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
croak("%s\n","Internal error, couldn't set TLS");
}
}
ithread* Perl_ithread_get (pTHX) {
SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
if(!thread_sv) {
croak("%s\n","Internal error, couldn't get TLS");
}
return INT2PTR(ithread*,SvIV(*thread_sv));
}
/* free any data (such as the perl interpreter) attached to an
* ithread structure. This is a bit like undef on SVs, where the SV
* isn't freed, but the PVX is.
* Must be called with thread->mutex already held
*/
static void
S_ithread_clear(pTHX_ ithread* thread)
{
PerlInterpreter *interp;
assert(thread->state & PERL_ITHR_FINISHED &&
(thread->state & PERL_ITHR_DETACHED ||
thread->state & PERL_ITHR_JOINED));
interp = thread->interp;
if (interp) {
dTHXa(interp);
ithread* current_thread;
#ifdef OEMVS
void *ptr;
#endif
PERL_SET_CONTEXT(interp);
current_thread = Perl_ithread_get(aTHX);
Perl_ithread_set(aTHX_ thread);
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
perl_destruct(interp);
thread->interp = NULL;
}
if (interp)
perl_free(interp);
PERL_SET_CONTEXT(aTHX);
}
/*
* free an ithread structure and any attached data if its count == 0
*/
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
MUTEX_LOCK(&thread->mutex);
if (!thread->next) {
MUTEX_UNLOCK(&thread->mutex);
Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
}
if (thread->count != 0) {
MUTEX_UNLOCK(&thread->mutex);
return;
}
MUTEX_LOCK(&create_destruct_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
/* last one should never get here ? */
threads = NULL;
}
else {
thread->next->prev = thread->prev;
thread->prev->next = thread->next;
if (threads == thread) {
threads = thread->next;
}
thread->next = NULL;
thread->prev = NULL;
}
known_threads--;
assert( known_threads >= 0 );
#if 0
Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
thread->tid,thread->interp,aTHX, known_threads);
#endif
MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
S_ithread_clear(aTHX_ thread);
MUTEX_UNLOCK(&thread->mutex);
MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
if (thread->handle)
CloseHandle(thread->handle);
thread->handle = 0;
#endif
PerlMemShared_free(thread);
}
int
Perl_ithread_hook(pTHX)
{
int veto_cleanup = 0;
MUTEX_LOCK(&create_destruct_mutex);
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);
veto_cleanup = 1;
}
MUTEX_UNLOCK(&create_destruct_mutex);
return veto_cleanup;
}
void
Perl_ithread_detach(pTHX_ ithread *thread)
{
MUTEX_LOCK(&thread->mutex);
if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
thread->state |= PERL_ITHR_DETACHED;
#ifdef WIN32
CloseHandle(thread->handle);
thread->handle = 0;
#else
PERL_THREAD_DETACH(thread->thr);
#endif
}
if ((thread->state & PERL_ITHR_FINISHED) &&
(thread->state & PERL_ITHR_DETACHED)) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detach");
}
else {
MUTEX_UNLOCK(&thread->mutex);
}
}
/* MAGIC (in mg.h sense) hooks */
int
ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
ithread *thread = (ithread *) mg->mg_ptr;
SvIV_set(sv, PTR2IV(thread));
SvIOK_on(sv);
return 0;
}
int
ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
ithread *thread = (ithread *) mg->mg_ptr;
MUTEX_LOCK(&thread->mutex);
thread->count--;
if (thread->count == 0) {
if(thread->state & PERL_ITHR_FINISHED &&
(thread->state & PERL_ITHR_DETACHED ||
thread->state & PERL_ITHR_JOINED))
{
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "no reference");
}
else {
MUTEX_UNLOCK(&thread->mutex);
}
}
else {
MUTEX_UNLOCK(&thread->mutex);
}
return 0;
}
int
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
ithread *thread = (ithread *) mg->mg_ptr;
MUTEX_LOCK(&thread->mutex);
thread->count++;
MUTEX_UNLOCK(&thread->mutex);
return 0;
}
MGVTBL ithread_vtbl = {
ithread_mg_get, /* get */
0, /* set */
0, /* len */
0, /* clear */
ithread_mg_free, /* free */
0, /* copy */
ithread_mg_dup /* dup */
};
/*
* Starts executing the thread. Needs to clean up memory a tad better.
* Passed as the C level function to run in the new thread
*/
#ifdef WIN32
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
ithread* thread = (ithread*) arg;
dTHXa(thread->interp);
PERL_SET_CONTEXT(thread->interp);
Perl_ithread_set(aTHX_ thread);
#if 0
/* Far from clear messing with ->thr child-side is a good idea */
MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
MUTEX_UNLOCK(&thread->mutex);
#endif
PL_perl_destruct_level = 2;
{
AV* params = (AV*) SvRV(thread->params);
I32 len = av_len(params)+1;
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for(i = 0; i < len; i++) {
XPUSHs(av_shift(params));
}
PUTBACK;
len = call_sv(thread->init_function, thread->gimme|G_EVAL);
SPAGAIN;
for (i=len-1; i >= 0; i--) {
SV *sv = POPs;
av_store(params, i, SvREFCNT_inc(sv));
}
if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
}
FREETMPS;
LEAVE;
SvREFCNT_dec(thread->init_function);
}
PerlIO_flush((PerlIO*)NULL);
MUTEX_LOCK(&thread->mutex);
thread->state |= PERL_ITHR_FINISHED;
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detached finish");
} else {
MUTEX_UNLOCK(&thread->mutex);
}
MUTEX_LOCK(&create_destruct_mutex);
active_threads--;
assert( active_threads >= 0 );
MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return (DWORD)0;
#else
return 0;
#endif
}
SV *
ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
{
SV *sv;
MAGIC *mg;
if (inc) {
MUTEX_LOCK(&thread->mutex);
thread->count++;
MUTEX_UNLOCK(&thread->mutex);
}
if (!obj)
obj = newSV(0);
sv = newSVrv(obj,classname);
sv_setiv(sv,PTR2IV(thread));
mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
mg->mg_flags |= MGf_DUP;
SvREADONLY_on(sv);
return obj;
}
ithread *
SV_to_ithread(pTHX_ SV *sv)
{
if (SvROK(sv))
{
return INT2PTR(ithread*, SvIV(SvRV(sv)));
}
else
{
return Perl_ithread_get(aTHX);
}
}
/*
* ithread->create(); ( aka ithread->new() )
* Called in context of parent thread
*/
SV *
Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
{
ithread* thread;
CLONE_PARAMS clone_param;
ithread* current_thread = Perl_ithread_get(aTHX);
SV** tmps_tmp = PL_tmps_stack;
I32 tmps_ix = PL_tmps_ix;
#ifndef WIN32
int failure;
const char* panic = NULL;
#endif
MUTEX_LOCK(&create_destruct_mutex);
thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
if (!thread) {
MUTEX_UNLOCK(&create_destruct_mutex);
PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, strlen(PL_no_mem));
my_exit(1);
}
Zero(thread,1,ithread);
thread->next = threads;
thread->prev = threads->prev;
threads->prev = thread;
thread->prev->next = thread;
/* Set count to 1 immediately in case thread exits before
* we return to caller !
*/
thread->count = 1;
MUTEX_INIT(&thread->mutex);
thread->tid = tid_counter++;
thread->gimme = GIMME_V;
/* "Clone" our interpreter into the thread's interpreter
* This gives thread access to "static data" and code.
*/
PerlIO_flush((PerlIO*)NULL);
Perl_ithread_set(aTHX_ thread);
SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
value */
PL_srand_called = FALSE; /* Set it to false so we can detect
if it gets set during the clone */
#ifdef WIN32
thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
#else
thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
#endif
/* perl_clone leaves us in new interpreter's context.
As it is tricky to spot an implicit aTHX, create a new scope
with aTHX matching the context for the duration of
our work for new interpreter.
*/
{
dTHXa(thread->interp);
/* Here we remove END blocks since they should only run
in the thread they are created
*/
SvREFCNT_dec(PL_endav);
PL_endav = newAV();
clone_param.flags = 0;
thread->init_function = sv_dup(init_function, &clone_param);
if (SvREFCNT(thread->init_function) == 0) {
SvREFCNT_inc(thread->init_function);
}
thread->params = sv_dup(params, &clone_param);
SvREFCNT_inc(thread->params);
/* The code below checks that anything living on
the tmps stack and has been cloned (so it lives in the
ptr_table) has a refcount higher than 0
If the refcount is 0 it means that a something on the
stack/context was holding a reference to it and
since we init_stacks() in perl_clone that won't get
cleaned and we will get a leaked scalar.
The reason it was cloned was that it lived on the
@_ stack.
Example of this can be found in bugreport 15837
where calls in the parameter list end up as a temp
One could argue that this fix should be in perl_clone
*/
while (tmps_ix > 0) {
SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
tmps_ix--;
if (sv && SvREFCNT(sv) == 0) {
SvREFCNT_inc(sv);
SvREFCNT_dec(sv);
}
}
SvTEMP_off(thread->init_function);
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
}
Perl_ithread_set(aTHX_ current_thread);
PERL_SET_CONTEXT(aTHX);
/* Start the thread */
#ifdef WIN32
thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
(LPVOID)thread, 0, &thread->thr);
#else
{
static pthread_attr_t attr;
static int attr_inited = 0;
static int attr_joinable = PTHREAD_CREATE_JOINABLE;
if (!attr_inited) {
attr_inited = 1;
pthread_attr_init(&attr);
}
# ifdef PTHREAD_ATTR_SETDETACHSTATE
PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
# endif
# ifdef THREAD_CREATE_NEEDS_STACK
if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
panic = "panic: pthread_attr_setstacksize failed";
# endif
#ifdef OLD_PTHREADS_API
failure
= panic ? 1 : pthread_create( &thread->thr, attr,
Perl_ithread_run, (void *)thread);
#else
# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
# endif
failure
= panic ? 1 : pthread_create( &thread->thr, &attr,
Perl_ithread_run, (void *)thread);
#endif
}
#endif
known_threads++;
if (
#ifdef WIN32
thread->handle == NULL
#else
failure
#endif
) {
MUTEX_UNLOCK(&create_destruct_mutex);
sv_2mortal(params);
Perl_ithread_destruct(aTHX_ thread, "create failed");
#ifndef WIN32
if (panic)
Perl_croak(aTHX_ panic);
#endif
return &PL_sv_undef;
}
active_threads++;
MUTEX_UNLOCK(&create_destruct_mutex);
sv_2mortal(params);
return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
}
SV*
Perl_ithread_self (pTHX_ SV *obj, char* Class)
{
ithread *thread = Perl_ithread_get(aTHX);
if (thread)
return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
else
Perl_croak(aTHX_ "panic: cannot find thread data");
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*
Perl_ithread_join(pTHX_ SV *obj)
{
ithread *thread = SV_to_ithread(aTHX_ obj);
MUTEX_LOCK(&thread->mutex);
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_croak(aTHX_ "Cannot join a detached thread");
}
else if (thread->state & PERL_ITHR_JOINED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_croak(aTHX_ "Thread already joined");
}
else {
AV* retparam;
#ifdef WIN32
DWORD waitcode;
#else
void *retval;
#endif
MUTEX_UNLOCK(&thread->mutex);
#ifdef WIN32
waitcode = WaitForSingleObject(thread->handle, INFINITE);
CloseHandle(thread->handle);
thread->handle = 0;
#else
pthread_join(thread->thr,&retval);
#endif
MUTEX_LOCK(&thread->mutex);
/* sv_dup over the args */
{
ithread* current_thread;
AV* params = (AV*) SvRV(thread->params);
PerlInterpreter *other_perl = thread->interp;
CLONE_PARAMS clone_params;
clone_params.stashes = newAV();
clone_params.flags |= CLONEf_JOIN_IN;
PL_ptr_table = ptr_table_new();
current_thread = Perl_ithread_get(aTHX);
Perl_ithread_set(aTHX_ thread);
/* ensure 'meaningful' addresses retain their meaning */
ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
#if 0
{
I32 len = av_len(params)+1;
I32 i;
for(i = 0; i < len; i++) {
sv_dump(SvRV(AvARRAY(params)[i]));
}
}
#endif
retparam = (AV*) sv_dup((SV*)params, &clone_params);
#if 0
{
I32 len = av_len(retparam)+1;
I32 i;
for(i = 0; i < len; i++) {
sv_dump(SvRV(AvARRAY(retparam)[i]));
}
}
#endif
Perl_ithread_set(aTHX_ current_thread);
SvREFCNT_dec(clone_params.stashes);
SvREFCNT_inc(retparam);
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
/* We are finished with it */
thread->state |= PERL_ITHR_JOINED;
S_ithread_clear(aTHX_ thread);
MUTEX_UNLOCK(&thread->mutex);
return retparam;
}
return (AV*)NULL;
}
void
Perl_ithread_DESTROY(pTHX_ SV *sv)
{
ithread *thread = SV_to_ithread(aTHX_ sv);
sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
}
#endif /* USE_ITHREADS */
MODULE = threads PACKAGE = threads PREFIX = ithread_
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);
}
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);
}
void
ithread_self(char *classname)
CODE:
{
ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
XSRETURN(1);
}
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);
}
void
yield(...)
CODE:
{
YIELD;
}
void
ithread_detach(ithread *thread)
void
ithread_DESTROY(SV *thread)
#endif /* USE_ITHREADS */
BOOT:
{
#ifdef USE_ITHREADS
ithread* thread;
PL_perl_destruct_level = 2;
MUTEX_INIT(&create_destruct_mutex);
MUTEX_LOCK(&create_destruct_mutex);
PL_threadhook = &Perl_ithread_hook;
thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
if (!thread) {
PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, strlen(PL_no_mem));
my_exit(1);
}
Zero(thread,1,ithread);
PL_perl_destruct_level = 2;
MUTEX_INIT(&thread->mutex);
threads = thread;
thread->next = thread;
thread->prev = thread;
thread->interp = aTHX;
thread->count = 1; /* Immortal. */
thread->tid = tid_counter++;
known_threads++;
active_threads++;
thread->state = PERL_ITHR_DETACHED;
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
Perl_ithread_set(aTHX_ thread);
MUTEX_UNLOCK(&create_destruct_mutex);
#endif /* USE_ITHREADS */
}
--- NEW FILE: README ---
threads version 0.03
====================
This module needs perl 5.7.2 or later compiled with USEITHREADS,
it exposes interpreter threads to the perl level.
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
This module requires these other modules and libraries:
COPYRIGHT AND LICENCE
Copyright (C) 2001 Artur Bergman artur at contiller.se
Same licence as perl.
--- NEW FILE: threads.pm ---
package threads;
use 5.008;
use strict;
use warnings;
use Config;
BEGIN {
unless ($Config{useithreads}) {
my @caller = caller(2);
die <<EOF;
$caller[1] line $caller[2]:
This Perl hasn't been configured and built properly for the threads
module to work. (The 'useithreads' configuration option hasn't been used.)
Having threads support requires all of Perl and all of the XS modules in
the Perl installation to be rebuilt, it is not just a question of adding
the threads module. (In other words, threaded and non-threaded Perls
are binary incompatible.)
If you want to the use the threads module, please contact the people
who built your Perl.
Cannot continue, aborting.
EOF
}
}
use overload
'==' => \&equal,
'fallback' => 1;
BEGIN {
warn "Warning, threads::shared has already been loaded. ".
"To enable shared variables for these modules 'use threads' ".
"must be called before any of those modules are loaded\n"
if($threads::shared::threads_shared);
}
require Exporter;
require DynaLoader;
our @ISA = qw(Exporter DynaLoader);
our %EXPORT_TAGS = ( all => [qw(yield)]);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
async
);
our $VERSION = '1.07';
# || 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;
bootstrap threads $VERSION;
# why document 'new' then use 'create' in the tests!
*create = \&new;
# Preloaded methods go here.
1;
__END__
=head1 NAME
threads - Perl extension allowing use of interpreter based threads from perl
=head1 SYNOPSIS
use threads;
sub start_thread {
print "Thread started\n";
}
my $thread = threads->create("start_thread","argument");
my $thread2 = $thread->create(sub { print "I am a thread"},"argument");
my $thread3 = async { foreach (@files) { ... } };
$thread->join();
$thread->detach();
$thread = threads->self();
$thread = threads->object( $tid );
$thread->tid();
threads->tid();
threads->self->tid();
threads->yield();
threads->list();
=head1 DESCRIPTION
Perl 5.6 introduced something called interpreter threads. Interpreter
threads are different from "5005threads" (the thread model of Perl
5.005) by creating a new perl interpreter per thread and not sharing
any data or state between threads by default.
Prior to perl 5.8 this has only been available to people embedding
perl and for emulating fork() on windows.
The threads API is loosely based on the old Thread.pm API. It is very
important to note that variables are not shared between threads, all
variables are per default thread local. To use shared variables one
must use threads::shared.
It is also important to note that you must enable threads by doing
C<use threads> as early as possible in the script itself and that it
is not possible to enable threading inside an C<eval "">, C<do>,
C<require>, or C<use>. In particular, if you are intending to share
variables with threads::shared, you must C<use threads> before you
C<use threads::shared> and C<threads> will emit a warning if you do
it the other way around.
=over
=item $thread = threads->create(function, LIST)
This will create a new thread with the entry point function and give
it LIST as parameters. It will return the corresponding threads
object, or C<undef> if thread creation failed. The new() method is an
alias for create().
=item $thread->join
This will wait for the corresponding thread to join. When the thread
finishes, join() will return the return values of the entry point
function. If the thread has been detached, an error will be thrown.
The context (void, scalar or list) of the thread creation is also the
context for join(). This means that if you intend to return an array
from a thread, you must use C<my ($thread) = threads->new(...)>, and
that if you intend to return a scalar, you must use C<my $thread = ...>.
If the program exits without all other threads having been either
joined or detached, then a warning will be issued. (A program exits
either because one of its threads explicitly calls exit(), or in the
case of the main thread, reaches the end of the main program file.)
=item $thread->detach
Will make the thread unjoinable, and cause any eventual return value
to be discarded.
=item threads->self
This will return the thread object for the current thread.
=item $thread->tid
This will return the id of the thread. Thread IDs are integers, with
the main thread in a program being 0. Currently Perl assigns a unique
tid to every thread ever created in your program, assigning the first
thread to be created a tid of 1, and increasing the tid by 1 for each
new thread that's created.
NB the class method C<< threads->tid() >> is a quick way to get the
current thread id if you don't have your thread object handy.
=item threads->object( tid )
This will return the thread object for the thread associated with the
specified tid. Returns undef if there is no thread associated with the tid
or no tid is specified or the specified tid is undef.
=item threads->yield();
This is a suggestion to the OS to let this thread yield CPU time to other
threads. What actually happens is highly dependent upon the underlying
thread implementation.
You may do C<use threads qw(yield)> then use just a bare C<yield> in your
code.
=item threads->list();
This will return a list of all non joined, non detached threads.
=item async BLOCK;
C<async> creates a thread to execute the block immediately following
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<async>
returns a thread object.
=back
=head1 WARNINGS
=over 4
=item A thread exited while %d other threads were still running
A thread (not necessarily the main thread) exited while there were
still other threads running. Usually it's a good idea to first collect
the return values of the created threads by joining them, and only then
exit from the main thread.
=back
=head1 TODO
The current implementation of threads has been an attempt to get
a correct threading system working that could be built on,
and optimized, in newer versions of perl.
Currently the overhead of creating a thread is rather large,
also the cost of returning values can be large. These are areas
were there most likely will be work done to optimize what data
that needs to be cloned.
=head1 BUGS
=over
=item Parent-Child threads.
On some platforms it might not be possible to destroy "parent"
threads while there are still existing child "threads".
This will possibly be fixed in later versions of perl.
=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 Returning objects
When you return an object the entire stash that the object is blessed
as well. This will lead to a large memory usage. The ideal situation
would be to detect the original stash if it existed.
=item Creating threads inside BEGIN blocks
Creating threads inside BEGIN blocks (or during the compilation phase
in general) does not work. (In Windows, trying to use fork() inside
BEGIN blocks is an equally losing proposition, since it has been
implemented in very much the same way as threads.)
=item PERL_OLD_SIGNALS are not threadsafe, will not be.
If your Perl has been built with PERL_OLD_SIGNALS (one has
to explicitly add that symbol to ccflags, see C<perl -V>),
signal handling is not threadsafe.
=back
=head1 AUTHOR and COPYRIGHT
Arthur Bergman E<lt>sky at nanisky.comE<gt>
threads is released under the same license as Perl.
Thanks to
Richard Soderberg E<lt>perl at crystalflame.netE<gt>
Helping me out tons, trying to find reasons for races and other weird bugs!
Simon Cozens E<lt>simon at brecon.co.ukE<gt>
Being there to answer zillions of annoying questions
Rocco Caputo E<lt>troc at netrus.netE<gt>
Vipul Ved Prakash E<lt>mail at vipul.netE<gt>
Helping with debugging.
please join perl-ithreads at perl.org for more information
=head1 SEE ALSO
L<threads::shared>, L<perlthrtut>,
L<http://www.perl.com/pub/a/2002/06/11/threads.html>,
L<perlcall>, L<perlembed>, L<perlguts>
=cut
--- NEW FILE: Changes ---
Revision history for Perl extension threads.
0.03 Mon Jul 2 12:00:50 CEST 2001
Fixed bug with threads->self() in main thread, thanks Hackworth!
0.02 Sat Jun 30 09:41:00 GMT 2001
Fixed bug in threads->self() reported by Hackworth
0.01 Tue Apr 24 19:04:12 2001
Cleaned up documentation
--- NEW FILE: typemap ---
ithread * T_ITHREAD
INPUT
T_ITHREAD
$var = SV_to_ithread(aTHX_ $arg)
OUTPUT
T_ITHREAD
ithread_to_SV(aTHX_ $arg, $var, classname, TRUE);
More information about the dslinux-commit
mailing list