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, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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