ext/threads/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));
}


/*
 *  Clear up after thread is done with
 */
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
        PerlInterpreter *freeperl = NULL;
        MUTEX_LOCK(&thread->mutex);
        if (!thread->next) {
            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 */

        if(thread->interp) {
            dTHXa(thread->interp);
            ithread*        current_thread;
#ifdef OEMVS
            void *ptr;
#endif
            PERL_SET_CONTEXT(thread->interp);
            current_thread = Perl_ithread_get(aTHX);
            Perl_ithread_set(aTHX_ thread);


            SvREFCNT_dec(thread->params);


            thread->params = Nullsv;
            perl_destruct(thread->interp);
            freeperl = thread->interp;
            thread->interp = NULL;
        }
        MUTEX_UNLOCK(&thread->mutex);
        MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
        if (thread->handle)
            CloseHandle(thread->handle);
        thread->handle = 0;
#endif
        PerlMemShared_free(thread);
        if (freeperl)
            perl_free(freeperl);

        PERL_SET_CONTEXT(aTHX);
}

int
Perl_ithread_hook(pTHX)
{
    int veto_cleanup = 0;
    MUTEX_LOCK(&create_destruct_mutex);
    if (aTHX == PL_curinterp && active_threads != 1) {
        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;
    SvIVX(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)) {
                    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 = 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
  {
   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;
        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  = 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 */
}

Revision:	1.1
Committed:	Thu Jun 30 14:27:06 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	Content
1	#define PERL_NO_GET_CONTEXT
2	#include "EXTERN.h"
3	#include "perl.h"
4	#include "XSUB.h"
5
6	#ifdef USE_ITHREADS
7
8
9	#ifdef WIN32
10	#include <windows.h>
11	#include <win32thread.h>
12	#else
13	#ifdef OS2
14	typedef perl_os_thread pthread_t;
15	#else
16	#include <pthread.h>
17	#endif
18	#include <thread.h>
19	#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
20	#ifdef OLD_PTHREADS_API
21	#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
22	#else
23	#define PERL_THREAD_DETACH(t) pthread_detach((t))
24	#endif /* OLD_PTHREADS_API */
25	#endif
26
27
28
29
30	/* Values for 'state' member */
31	#define PERL_ITHR_JOINABLE 0
32	#define PERL_ITHR_DETACHED 1
33	#define PERL_ITHR_FINISHED 4
34	#define PERL_ITHR_JOINED 2
35
36	typedef struct ithread_s {
37	struct ithread_s next; / Next thread in the list */
38	struct ithread_s prev; / Prev thread in the list */
39	PerlInterpreter interp; / The threads interpreter */
40	I32 tid; /* Threads module's thread id */
41	perl_mutex mutex; /* Mutex for updating things in this struct */
42	I32 count; /* How many SVs have a reference to us */
43	signed char state; /* Are we detached ? */
44	int gimme; /* Context of create */
45	SV* init_function; /* Code to run */
46	SV* params; /* Args to pass function */
47	#ifdef WIN32
48	DWORD thr; /* OS's idea if thread id */
49	HANDLE handle; /* OS's waitable handle */
50	#else
51	pthread_t thr; /* OS's handle for the thread */
52	#endif
53	} ithread;
54
55	ithread *threads;
56
57	/* Macros to supply the aTHX_ in an embed.h like manner */
58	#define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
59	#define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
60	#define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
61	#define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
62	#define ithread_tid(thread) ((thread)->tid)
63	#define ithread_yield(thread) (YIELD);
64
65	static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
66
67	I32 tid_counter = 0;
68	I32 known_threads = 0;
69	I32 active_threads = 0;
70
71
72	void Perl_ithread_set (pTHX_ ithread* thread)
73	{
74	SV* thread_sv = newSViv(PTR2IV(thread));
75	if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
76	croak("%s\n","Internal error, couldn't set TLS");
77	}
78	}
79
80	ithread* Perl_ithread_get (pTHX) {
81	SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
82	if(!thread_sv) {
83	croak("%s\n","Internal error, couldn't get TLS");
84	}
85	return INT2PTR(ithread,SvIV(thread_sv));
86	}
87
88
89
90	/*
91	* Clear up after thread is done with
92	*/
93	void
94	Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
95	{
96	PerlInterpreter *freeperl = NULL;
97	MUTEX_LOCK(&thread->mutex);
98	if (!thread->next) {
99	Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
100	}
101	if (thread->count != 0) {
102	MUTEX_UNLOCK(&thread->mutex);
103	return;
104	}
105	MUTEX_LOCK(&create_destruct_mutex);
106	/* Remove from circular list of threads */
107	if (thread->next == thread) {
108	/* last one should never get here ? */
109	threads = NULL;
110	}
111	else {
112	thread->next->prev = thread->prev;
113	thread->prev->next = thread->next;
114	if (threads == thread) {
115	threads = thread->next;
116	}
117	thread->next = NULL;
118	thread->prev = NULL;
119	}
120	known_threads--;
121	assert( known_threads >= 0 );
122	#if 0
123	Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
124	thread->tid,thread->interp,aTHX, known_threads);
125	#endif
126	MUTEX_UNLOCK(&create_destruct_mutex);
127	/* Thread is now disowned */
128
129	if(thread->interp) {
130	dTHXa(thread->interp);
131	ithread* current_thread;
132	#ifdef OEMVS
133	void *ptr;
134	#endif
135	PERL_SET_CONTEXT(thread->interp);
136	current_thread = Perl_ithread_get(aTHX);
137	Perl_ithread_set(aTHX_ thread);
138
139
140
141
142	SvREFCNT_dec(thread->params);
143
144
145
146	thread->params = Nullsv;
147	perl_destruct(thread->interp);
148	freeperl = thread->interp;
149	thread->interp = NULL;
150	}
151	MUTEX_UNLOCK(&thread->mutex);
152	MUTEX_DESTROY(&thread->mutex);
153	#ifdef WIN32
154	if (thread->handle)
155	CloseHandle(thread->handle);
156	thread->handle = 0;
157	#endif
158	PerlMemShared_free(thread);
159	if (freeperl)
160	perl_free(freeperl);
161
162	PERL_SET_CONTEXT(aTHX);
163	}
164
165	int
166	Perl_ithread_hook(pTHX)
167	{
168	int veto_cleanup = 0;
169	MUTEX_LOCK(&create_destruct_mutex);
170	if (aTHX == PL_curinterp && active_threads != 1) {
171	Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
172	(IV)active_threads);
173	veto_cleanup = 1;
174	}
175	MUTEX_UNLOCK(&create_destruct_mutex);
176	return veto_cleanup;
177	}
178
179	void
180	Perl_ithread_detach(pTHX_ ithread *thread)
181	{
182	MUTEX_LOCK(&thread->mutex);
183	if (!(thread->state & (PERL_ITHR_DETACHED\|PERL_ITHR_JOINED))) {
184	thread->state \|= PERL_ITHR_DETACHED;
185	#ifdef WIN32
186	CloseHandle(thread->handle);
187	thread->handle = 0;
188	#else
189	PERL_THREAD_DETACH(thread->thr);
190	#endif
191	}
192	if ((thread->state & PERL_ITHR_FINISHED) &&
193	(thread->state & PERL_ITHR_DETACHED)) {
194	MUTEX_UNLOCK(&thread->mutex);
195	Perl_ithread_destruct(aTHX_ thread, "detach");
196	}
197	else {
198	MUTEX_UNLOCK(&thread->mutex);
199	}
200	}
201
202	/* MAGIC (in mg.h sense) hooks */
203
204	int
205	ithread_mg_get(pTHX_ SV sv, MAGIC mg)
206	{
207	ithread thread = (ithread ) mg->mg_ptr;
208	SvIVX(sv) = PTR2IV(thread);
209	SvIOK_on(sv);
210	return 0;
211	}
212
213	int
214	ithread_mg_free(pTHX_ SV sv, MAGIC mg)
215	{
216	ithread thread = (ithread ) mg->mg_ptr;
217	MUTEX_LOCK(&thread->mutex);
218	thread->count--;
219	if (thread->count == 0) {
220	if(thread->state & PERL_ITHR_FINISHED &&
221	(thread->state & PERL_ITHR_DETACHED \|\|
222	thread->state & PERL_ITHR_JOINED))
223	{
224	MUTEX_UNLOCK(&thread->mutex);
225	Perl_ithread_destruct(aTHX_ thread, "no reference");
226	}
227	else {
228	MUTEX_UNLOCK(&thread->mutex);
229	}
230	}
231	else {
232	MUTEX_UNLOCK(&thread->mutex);
233	}
234	return 0;
235	}
236
237	int
238	ithread_mg_dup(pTHX_ MAGIC mg, CLONE_PARAMS param)
239	{
240	ithread thread = (ithread ) mg->mg_ptr;
241	MUTEX_LOCK(&thread->mutex);
242	thread->count++;
243	MUTEX_UNLOCK(&thread->mutex);
244	return 0;
245	}
246
247	MGVTBL ithread_vtbl = {
248	ithread_mg_get, /* get */
249	0, /* set */
250	0, /* len */
251	0, /* clear */
252	ithread_mg_free, /* free */
253	0, /* copy */
254	ithread_mg_dup /* dup */
255	};
256
257
258	/*
259	* Starts executing the thread. Needs to clean up memory a tad better.
260	* Passed as the C level function to run in the new thread
261	*/
262
263	#ifdef WIN32
264	THREAD_RET_TYPE
265	Perl_ithread_run(LPVOID arg) {
266	#else
267	void*
268	Perl_ithread_run(void * arg) {
269	#endif
270	ithread* thread = (ithread*) arg;
271	dTHXa(thread->interp);
272	PERL_SET_CONTEXT(thread->interp);
273	Perl_ithread_set(aTHX_ thread);
274
275	#if 0
276	/* Far from clear messing with ->thr child-side is a good idea */
277	MUTEX_LOCK(&thread->mutex);
278	#ifdef WIN32
279	thread->thr = GetCurrentThreadId();
280	#else
281	thread->thr = pthread_self();
282	#endif
283	MUTEX_UNLOCK(&thread->mutex);
284	#endif
285
286	PL_perl_destruct_level = 2;
287
288	{
289	AV* params = (AV*) SvRV(thread->params);
290	I32 len = av_len(params)+1;
291	int i;
292	dSP;
293	ENTER;
294	SAVETMPS;
295	PUSHMARK(SP);
296	for(i = 0; i < len; i++) {
297	XPUSHs(av_shift(params));
298	}
299	PUTBACK;
300	len = call_sv(thread->init_function, thread->gimme\|G_EVAL);
301
302	SPAGAIN;
303	for (i=len-1; i >= 0; i--) {
304	SV *sv = POPs;
305	av_store(params, i, SvREFCNT_inc(sv));
306	}
307	if (SvTRUE(ERRSV)) {
308	Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
309	}
310	FREETMPS;
311	LEAVE;
312	SvREFCNT_dec(thread->init_function);
313	}
314
315	PerlIO_flush((PerlIO*)NULL);
316	MUTEX_LOCK(&thread->mutex);
317	thread->state \|= PERL_ITHR_FINISHED;
318
319	if (thread->state & PERL_ITHR_DETACHED) {
320	MUTEX_UNLOCK(&thread->mutex);
321	Perl_ithread_destruct(aTHX_ thread, "detached finish");
322	} else {
323	MUTEX_UNLOCK(&thread->mutex);
324	}
325	MUTEX_LOCK(&create_destruct_mutex);
326	active_threads--;
327	assert( active_threads >= 0 );
328	MUTEX_UNLOCK(&create_destruct_mutex);
329
330	#ifdef WIN32
331	return (DWORD)0;
332	#else
333	return 0;
334	#endif
335	}
336
337	SV *
338	ithread_to_SV(pTHX_ SV obj, ithread thread, char *classname, bool inc)
339	{
340	SV *sv;
341	MAGIC *mg;
342	if (inc) {
343	MUTEX_LOCK(&thread->mutex);
344	thread->count++;
345	MUTEX_UNLOCK(&thread->mutex);
346	}
347	if (!obj)
348	obj = newSV(0);
349	sv = newSVrv(obj,classname);
350	sv_setiv(sv,PTR2IV(thread));
351	mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
352	mg->mg_flags \|= MGf_DUP;
353	SvREADONLY_on(sv);
354	return obj;
355	}
356
357	ithread *
358	SV_to_ithread(pTHX_ SV *sv)
359	{
360	if (SvROK(sv))
361	{
362	return INT2PTR(ithread*, SvIV(SvRV(sv)));
363	}
364	else
365	{
366	return Perl_ithread_get(aTHX);
367	}
368	}
369
370	/*
371	* ithread->create(); ( aka ithread->new() )
372	* Called in context of parent thread
373	*/
374
375	SV *
376	Perl_ithread_create(pTHX_ SV obj, char classname, SV* init_function, SV* params)
377	{
378	ithread* thread;
379	CLONE_PARAMS clone_param;
380	ithread* current_thread = Perl_ithread_get(aTHX);
381
382	SV** tmps_tmp = PL_tmps_stack;
383	I32 tmps_ix = PL_tmps_ix;
384	#ifndef WIN32
385	int failure;
386	const char* panic = NULL;
387	#endif
388
389
390	MUTEX_LOCK(&create_destruct_mutex);
391	thread = PerlMemShared_malloc(sizeof(ithread));
392	if (!thread) {
393	MUTEX_UNLOCK(&create_destruct_mutex);
394	PerlLIO_write(PerlIO_fileno(Perl_error_log),
395	PL_no_mem, strlen(PL_no_mem));
396	my_exit(1);
397	}
398	Zero(thread,1,ithread);
399	thread->next = threads;
400	thread->prev = threads->prev;
401	threads->prev = thread;
402	thread->prev->next = thread;
403	/* Set count to 1 immediately in case thread exits before
404	* we return to caller !
405	*/
406	thread->count = 1;
407	MUTEX_INIT(&thread->mutex);
408	thread->tid = tid_counter++;
409	thread->gimme = GIMME_V;
410
411	/* "Clone" our interpreter into the thread's interpreter
412	* This gives thread access to "static data" and code.
413	*/
414
415	PerlIO_flush((PerlIO*)NULL);
416	Perl_ithread_set(aTHX_ thread);
417
418	SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
419	value */
420	PL_srand_called = FALSE; /* Set it to false so we can detect
421	if it gets set during the clone */
422
423	#ifdef WIN32
424	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE \| CLONEf_CLONE_HOST);
425	#else
426	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
427	#endif
428	/* perl_clone leaves us in new interpreter's context.
429	As it is tricky to spot an implicit aTHX, create a new scope
430	with aTHX matching the context for the duration of
431	our work for new interpreter.
432	*/
433	{
434	dTHXa(thread->interp);
435
436	/* Here we remove END blocks since they should only run
437	in the thread they are created
438	*/
439	SvREFCNT_dec(PL_endav);
440	PL_endav = newAV();
441	clone_param.flags = 0;
442	thread->init_function = sv_dup(init_function, &clone_param);
443	if (SvREFCNT(thread->init_function) == 0) {
444	SvREFCNT_inc(thread->init_function);
445	}
446
447
448
449	thread->params = sv_dup(params, &clone_param);
450	SvREFCNT_inc(thread->params);
451
452
453	/* The code below checks that anything living on
454	the tmps stack and has been cloned (so it lives in the
455	ptr_table) has a refcount higher than 0
456
457	If the refcount is 0 it means that a something on the
458	stack/context was holding a reference to it and
459	since we init_stacks() in perl_clone that won't get
460	cleaned and we will get a leaked scalar.
461	The reason it was cloned was that it lived on the
462	@_ stack.
463
464	Example of this can be found in bugreport 15837
465	where calls in the parameter list end up as a temp
466
467	One could argue that this fix should be in perl_clone
468	*/
469
470
471	while (tmps_ix > 0) {
472	SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
473	tmps_ix--;
474	if (sv && SvREFCNT(sv) == 0) {
475	SvREFCNT_inc(sv);
476	SvREFCNT_dec(sv);
477	}
478	}
479
480
481
482	SvTEMP_off(thread->init_function);
483	ptr_table_free(PL_ptr_table);
484	PL_ptr_table = NULL;
485	PL_exit_flags \|= PERL_EXIT_DESTRUCT_END;
486	}
487	Perl_ithread_set(aTHX_ current_thread);
488	PERL_SET_CONTEXT(aTHX);
489
490	/* Start the thread */
491
492	#ifdef WIN32
493	thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
494	(LPVOID)thread, 0, &thread->thr);
495	#else
496	{
497	static pthread_attr_t attr;
498	static int attr_inited = 0;
499	static int attr_joinable = PTHREAD_CREATE_JOINABLE;
500	if (!attr_inited) {
501	attr_inited = 1;
502	pthread_attr_init(&attr);
503	}
504	# ifdef PTHREAD_ATTR_SETDETACHSTATE
505	PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
506	# endif
507	# ifdef THREAD_CREATE_NEEDS_STACK
508	if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
509	panic = "panic: pthread_attr_setstacksize failed";
510	# endif
511
512	#ifdef OLD_PTHREADS_API
513	failure
514	= panic ? 1 : pthread_create( &thread->thr, attr,
515	Perl_ithread_run, (void *)thread);
516	#else
517	# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
518	pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
519	# endif
520	failure
521	= panic ? 1 : pthread_create( &thread->thr, &attr,
522	Perl_ithread_run, (void *)thread);
523	#endif
524	}
525	#endif
526	known_threads++;
527	if (
528	#ifdef WIN32
529	thread->handle == NULL
530	#else
531	failure
532	#endif
533	) {
534	MUTEX_UNLOCK(&create_destruct_mutex);
535	sv_2mortal(params);
536	Perl_ithread_destruct(aTHX_ thread, "create failed");
537	#ifndef WIN32
538	if (panic)
539	Perl_croak(aTHX_ panic);
540	#endif
541	return &PL_sv_undef;
542	}
543	active_threads++;
544	MUTEX_UNLOCK(&create_destruct_mutex);
545	sv_2mortal(params);
546
547	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
548	}
549
550	SV*
551	Perl_ithread_self (pTHX_ SV obj, char Class)
552	{
553	ithread *thread = Perl_ithread_get(aTHX);
554	if (thread)
555	return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
556	else
557	Perl_croak(aTHX_ "panic: cannot find thread data");
558	return NULL; /* silence compiler warning */
559	}
560
561	/*
562	* Joins the thread this code needs to take the returnvalue from the
563	* call_sv and send it back
564	*/
565
566	void
567	Perl_ithread_CLONE(pTHX_ SV *obj)
568	{
569	if (SvROK(obj))
570	{
571	ithread *thread = SV_to_ithread(aTHX_ obj);
572	}
573	else
574	{
575	Perl_warn(aTHX_ "CLONE %" SVf,obj);
576	}
577	}
578
579	AV*
580	Perl_ithread_join(pTHX_ SV *obj)
581	{
582	ithread *thread = SV_to_ithread(aTHX_ obj);
583	MUTEX_LOCK(&thread->mutex);
584	if (thread->state & PERL_ITHR_DETACHED) {
585	MUTEX_UNLOCK(&thread->mutex);
586	Perl_croak(aTHX_ "Cannot join a detached thread");
587	}
588	else if (thread->state & PERL_ITHR_JOINED) {
589	MUTEX_UNLOCK(&thread->mutex);
590	Perl_croak(aTHX_ "Thread already joined");
591	}
592	else {
593	AV* retparam;
594	#ifdef WIN32
595	DWORD waitcode;
596	#else
597	void *retval;
598	#endif
599	MUTEX_UNLOCK(&thread->mutex);
600	#ifdef WIN32
601	waitcode = WaitForSingleObject(thread->handle, INFINITE);
602	CloseHandle(thread->handle);
603	thread->handle = 0;
604	#else
605	pthread_join(thread->thr,&retval);
606	#endif
607	MUTEX_LOCK(&thread->mutex);
608
609	/* sv_dup over the args */
610	{
611	ithread* current_thread;
612	AV* params = (AV*) SvRV(thread->params);
613	PerlInterpreter *other_perl = thread->interp;
614	CLONE_PARAMS clone_params;
615	clone_params.stashes = newAV();
616	clone_params.flags \|= CLONEf_JOIN_IN;
617	PL_ptr_table = ptr_table_new();
618	current_thread = Perl_ithread_get(aTHX);
619	Perl_ithread_set(aTHX_ thread);
620	/* ensure 'meaningful' addresses retain their meaning */
621	ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
622	ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
623	ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
624
625	#if 0
626	{
627	I32 len = av_len(params)+1;
628	I32 i;
629	for(i = 0; i < len; i++) {
630	sv_dump(SvRV(AvARRAY(params)[i]));
631	}
632	}
633	#endif
634	retparam = (AV) sv_dup((SV)params, &clone_params);
635	#if 0
636	{
637	I32 len = av_len(retparam)+1;
638	I32 i;
639	for(i = 0; i < len; i++) {
640	sv_dump(SvRV(AvARRAY(retparam)[i]));
641	}
642	}
643	#endif
644	Perl_ithread_set(aTHX_ current_thread);
645	SvREFCNT_dec(clone_params.stashes);
646	SvREFCNT_inc(retparam);
647	ptr_table_free(PL_ptr_table);
648	PL_ptr_table = NULL;
649
650	}
651	/* We are finished with it */
652	thread->state \|= PERL_ITHR_JOINED;
653	MUTEX_UNLOCK(&thread->mutex);
654
655	return retparam;
656	}
657	return (AV*)NULL;
658	}
659
660	void
661	Perl_ithread_DESTROY(pTHX_ SV *sv)
662	{
663	ithread *thread = SV_to_ithread(aTHX_ sv);
664	sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
665	}
666
667	#endif /* USE_ITHREADS */
668
669	MODULE = threads PACKAGE = threads PREFIX = ithread_
670	PROTOTYPES: DISABLE
671
672	#ifdef USE_ITHREADS
673
674	void
675	ithread_new (classname, function_to_call, ...)
676	char * classname
677	SV * function_to_call
678	CODE:
679	{
680	AV* params = newAV();
681	if (items > 2) {
682	int i;
683	for(i = 2; i < items ; i++) {
684	av_push(params, SvREFCNT_inc(ST(i)));
685	}
686	}
687	ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
688	XSRETURN(1);
689	}
690
691	void
692	ithread_list(char *classname)
693	PPCODE:
694	{
695	ithread *curr_thread;
696	MUTEX_LOCK(&create_destruct_mutex);
697	curr_thread = threads;
698	if(curr_thread->tid != 0)
699	XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
700	while(curr_thread) {
701	curr_thread = curr_thread->next;
702	if(curr_thread == threads)
703	break;
704	if(curr_thread->state & PERL_ITHR_DETACHED \|\|
705	curr_thread->state & PERL_ITHR_JOINED)
706	continue;
707	XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
708	}
709	MUTEX_UNLOCK(&create_destruct_mutex);
710	}
711
712
713	void
714	ithread_self(char *classname)
715	CODE:
716	{
717	ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
718	XSRETURN(1);
719	}
720
721	int
722	ithread_tid(ithread *thread)
723
724	void
725	ithread_join(SV *obj)
726	PPCODE:
727	{
728	AV* params = Perl_ithread_join(aTHX_ obj);
729	int i;
730	I32 len = AvFILL(params);
731	for (i = 0; i <= len; i++) {
732	SV* tmp = av_shift(params);
733	XPUSHs(tmp);
734	sv_2mortal(tmp);
735	}
736	SvREFCNT_dec(params);
737	}
738
739	void
740	yield(...)
741	CODE:
742	{
743	YIELD;
744	}
745
746
747	void
748	ithread_detach(ithread *thread)
749
750	void
751	ithread_DESTROY(SV *thread)
752
753	#endif /* USE_ITHREADS */
754
755	BOOT:
756	{
757	#ifdef USE_ITHREADS
758	ithread* thread;
759	PL_perl_destruct_level = 2;
760	MUTEX_INIT(&create_destruct_mutex);
761	MUTEX_LOCK(&create_destruct_mutex);
762	PL_threadhook = &Perl_ithread_hook;
763	thread = PerlMemShared_malloc(sizeof(ithread));
764	if (!thread) {
765	PerlLIO_write(PerlIO_fileno(Perl_error_log),
766	PL_no_mem, strlen(PL_no_mem));
767	my_exit(1);
768	}
769	Zero(thread,1,ithread);
770	PL_perl_destruct_level = 2;
771	MUTEX_INIT(&thread->mutex);
772	threads = thread;
773	thread->next = thread;
774	thread->prev = thread;
775	thread->interp = aTHX;
776	thread->count = 1; /* Immortal. */
777	thread->tid = tid_counter++;
778	known_threads++;
779	active_threads++;
780	thread->state = PERL_ITHR_DETACHED;
781	#ifdef WIN32
782	thread->thr = GetCurrentThreadId();
783	#else
784	thread->thr = pthread_self();
785	#endif
786
787	Perl_ithread_set(aTHX_ thread);
788	MUTEX_UNLOCK(&create_destruct_mutex);
789	#endif /* USE_ITHREADS */
790	}
791