ext/threads/threads.xs

   1 #include "threads.h"
   2
   3 /*
   4  *      Starts executing the thread. Needs to clean up memory a tad better.
   5  */
   6
   7 #ifdef WIN32
   8 THREAD_RET_TYPE Perl_thread_run(LPVOID arg) {
   9 #else
  10 void* Perl_thread_run(void * arg) {
  11 #endif
  12         ithread* thread = (ithread*) arg;
  13         SV* thread_tid_ptr;
  14         SV* thread_ptr;
  15         dTHXa(thread->interp);
  16         PERL_SET_CONTEXT(thread->interp);
  17
  18 #ifdef WIN32
  19         thread->thr = GetCurrentThreadId();
  20 #else
  21         thread->thr = pthread_self();
  22 #endif
  23
  24         SHAREDSvLOCK(threads);
  25         SHAREDSvEDIT(threads);
  26         PERL_THREAD_ALLOC_SPECIFIC(self_key);
  27         PERL_THREAD_SETSPECIFIC(self_key,INT2PTR(void*,thread->tid));
  28         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, thread->tid);
  29         thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
  30         hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
  31         SvREFCNT_dec(thread_tid_ptr);
  32         SHAREDSvRELEASE(threads);
  33         SHAREDSvUNLOCK(threads);
  34         PL_perl_destruct_level = 2;
  35
  36         {
  37
  38                 AV* params;
  39                 I32 len;
  40                 int i;
  41                 dSP;
  42                 params = (AV*) SvRV(thread->params);
  43                 len = av_len(params);
  44                 ENTER;
  45                 SAVETMPS;
  46                 PUSHMARK(SP);
  47                 if(len > -1) {
  48                         for(i = 0; i < len + 1; i++) {
  49                                 XPUSHs(av_shift(params));
  50                         }
  51                 }
  52                 PUTBACK;
  53                 call_sv(thread->init_function, G_DISCARD);
  54                 FREETMPS;
  55                 LEAVE;
  56
  57
  58         }
  59
  60         MUTEX_LOCK(&thread->mutex);
  61         PerlIO_flush((PerlIO*)NULL);
  62         perl_destruct(thread->interp);
  63         perl_free(thread->interp);
  64         if(thread->detached == 1) {
  65                 MUTEX_UNLOCK(&thread->mutex);
  66                 Perl_thread_destruct(thread);
  67         } else {
  68                 MUTEX_UNLOCK(&thread->mutex);
  69         }
  70 #ifdef WIN32
  71         return (DWORD)0;
  72 #else
  73         return 0;
  74 #endif
  75
  76 }
  77
  78 /*
  79  * iThread->create();
  80  */
  81
  82 SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
  83         ithread* thread = malloc(sizeof(ithread));
  84         SV*      obj_ref;
  85         SV*      obj;
  86         SV*             temp_store;
  87         PerlInterpreter *current_perl;
  88
  89         MUTEX_LOCK(&create_mutex);
  90         obj_ref = newSViv(0);
  91         obj = newSVrv(obj_ref, class);
  92         sv_setiv(obj, (IV)thread);
  93         SvREADONLY_on(obj);
  94
  95         current_perl = PERL_GET_CONTEXT;
  96
  97         /*
  98          * here we put the values of params and function to call onto
  99          * namespace, this is so perl will properly clone them when we
 100          * call perl_clone.
 101          */
 102
 103         temp_store = Perl_get_sv(current_perl, "threads::paramtempstore",
 104                                  TRUE | GV_ADDMULTI);
 105         Perl_sv_setsv(current_perl, temp_store,params);
 106         params = NULL;
 107         temp_store = NULL;
 108
 109         temp_store = Perl_get_sv(current_perl, "threads::calltempstore",
 110                                  TRUE | GV_ADDMULTI);
 111         Perl_sv_setsv(current_perl,temp_store, init_function);
 112         init_function = NULL;
 113         temp_store = NULL;
 114
 115 #ifdef WIN32
 116         thread->interp = perl_clone(current_perl, 4);
 117 #else
 118         thread->interp = perl_clone(current_perl, 0);
 119 #endif
 120
 121         thread->init_function = newSVsv(Perl_get_sv(thread->interp,
 122                                                     "threads::calltempstore",FALSE));
 123         thread->params = newSVsv(Perl_get_sv(thread->interp,
 124                                              "threads::paramtempstore",FALSE));
 125
 126         /*
 127          * And here we make sure we clean up the data we put in the
 128          * namespace of iThread, both in the new and the calling
 129          * inteprreter */
 130
 131         temp_store = Perl_get_sv(thread->interp, "threads::paramtempstore",FALSE);
 132         Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
 133
 134         temp_store = Perl_get_sv(thread->interp,"threads::calltempstore",FALSE);
 135         Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
 136
 137         PERL_SET_CONTEXT(current_perl);
 138
 139         temp_store = Perl_get_sv(current_perl,"threads::paramtempstore",FALSE);
 140         Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
 141
 142         temp_store = Perl_get_sv(current_perl,"threads::calltempstore",FALSE);
 143         Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
 144
 145         /* let's init the thread */
 146
 147         MUTEX_INIT(&thread->mutex);
 148         thread->tid = tid_counter++;
 149         thread->detached = 0;
 150         thread->count = 1;
 151
 152 #ifdef WIN32
 153
 154         thread->handle = CreateThread(NULL, 0, Perl_thread_run,
 155                         (LPVOID)thread, 0, &thread->thr);
 156
 157
 158 #else
 159 #ifdef OLD_PTHREADS_API
 160         {
 161           static pthread_attr_t attr;
 162           static int attr_inited = 0;
 163           sigset_t fullmask, oldmask;
 164           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
 165           if (!attr_inited) {
 166             attr_inited = 1;
 167             pthread_attr_init(&attr);
 168           }
 169 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
 170             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 171 #  endif
 172
 173           pthread_create( &thread->thr, attr, Perl_thread_run, (void *)thread);
 174         }
 175 #else
 176         pthread_create( &thread->thr, (pthread_attr_t*)NULL, Perl_thread_run, (void *)thread);
 177 #endif
 178 #endif
 179         MUTEX_UNLOCK(&create_mutex);
 180
 181         return obj_ref;
 182 }
 183
 184 /*
 185  * returns the id of the thread
 186  */
 187 I32 Perl_thread_tid (SV* obj) {
 188         ithread* thread;
 189         if(!SvROK(obj)) {
 190                 obj = Perl_thread_self(SvPV_nolen(obj));
 191                 thread = (ithread*)SvIV(SvRV(obj));
 192                 SvREFCNT_dec(obj);
 193         } else {
 194                 thread = (ithread*)SvIV(SvRV(obj));
 195         }
 196         return thread->tid;
 197 }
 198
 199 SV* Perl_thread_self (char* class) {
 200         dTHX;
 201         SV*      obj_ref;
 202         SV*      obj;
 203         SV*     thread_tid_ptr;
 204         SV*     thread_ptr;
 205         HE*     thread_entry;
 206         void*   id;
 207         PERL_THREAD_GETSPECIFIC(self_key,id);
 208         SHAREDSvLOCK(threads);
 209         SHAREDSvEDIT(threads);
 210
 211         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(id));
 212
 213         thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
 214                                          (HV*) SHAREDSvGET(threads),
 215                                          thread_tid_ptr, 0,0);
 216         thread_ptr = HeVAL(thread_entry);
 217         SvREFCNT_dec(thread_tid_ptr);
 218         SHAREDSvRELEASE(threads);
 219         SHAREDSvUNLOCK(threads);
 220
 221         obj_ref = newSViv(0);
 222         obj = newSVrv(obj_ref, class);
 223         sv_setsv(obj, thread_ptr);
 224         SvREADONLY_on(obj);
 225         return obj_ref;
 226 }
 227
 228 /*
 229  * joins the thread this code needs to take the returnvalue from the
 230  * call_sv and send it back */
 231
 232 void Perl_thread_join(SV* obj) {
 233         ithread* thread = (ithread*)SvIV(SvRV(obj));
 234 #ifdef WIN32
 235         DWORD waitcode;
 236         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 237 #else
 238         void *retval;
 239         pthread_join(thread->thr,&retval);
 240 #endif
 241 }
 242
 243 /* detaches a thread
 244  * needs to better clean up memory */
 245
 246 void Perl_thread_detach(SV* obj) {
 247         ithread* thread = (ithread*)SvIV(SvRV(obj));
 248         MUTEX_LOCK(&thread->mutex);
 249         thread->detached = 1;
 250         PERL_THREAD_DETACH(thread->thr);
 251         MUTEX_UNLOCK(&thread->mutex);
 252 }
 253
 254 void Perl_thread_DESTROY (SV* obj) {
 255         ithread* thread = (ithread*)SvIV(SvRV(obj));
 256
 257         MUTEX_LOCK(&thread->mutex);
 258         thread->count--;
 259         MUTEX_UNLOCK(&thread->mutex);
 260         Perl_thread_destruct(thread);
 261 }
 262
 263 void Perl_thread_destruct (ithread* thread) {
 264         return;
 265         MUTEX_LOCK(&thread->mutex);
 266         if(thread->count != 0) {
 267                 MUTEX_UNLOCK(&thread->mutex);
 268                 return;
 269         }
 270         MUTEX_UNLOCK(&thread->mutex);
 271         /* it is safe noone is holding a ref to this */
 272         /*printf("proper destruction!\n");*/
 273 }
 274
 275 MODULE = threads                PACKAGE = threads
 276 BOOT:
 277         Perl_sharedsv_init(aTHX);
 278         PL_perl_destruct_level = 2;
 279         threads = Perl_sharedsv_new(aTHX);
 280         SHAREDSvEDIT(threads);
 281         SHAREDSvGET(threads) = (SV *)newHV();
 282         SHAREDSvRELEASE(threads);
 283         {
 284
 285
 286             SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
 287             SV* temp2 = newSViv((IV)PL_sharedsv_space );
 288             sv_setsv( temp , temp2 );
 289         }
 290         {
 291                 ithread* thread = malloc(sizeof(ithread));
 292                 SV* thread_tid_ptr;
 293                 SV* thread_ptr;
 294                 MUTEX_INIT(&thread->mutex);
 295                 thread->tid = 0;
 296 #ifdef WIN32
 297                 thread->thr = GetCurrentThreadId();
 298 #else
 299                 thread->thr = pthread_self();
 300 #endif
 301                 SHAREDSvEDIT(threads);
 302                 PERL_THREAD_ALLOC_SPECIFIC(self_key);
 303                 PERL_THREAD_SETSPECIFIC(self_key,0);
 304                 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, 0);
 305                 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
 306                 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
 307                 SvREFCNT_dec(thread_tid_ptr);
 308                 SHAREDSvRELEASE(threads);
 309         }
 310         MUTEX_INIT(&create_mutex);
 311
 312 PROTOTYPES: DISABLE
 313
 314 SV *
 315 create (class, function_to_call, ...)
 316         char *  class
 317         SV *    function_to_call
 318                 CODE:
 319                         AV* params = newAV();
 320                         if(items > 2) {
 321                                 int i;
 322                                 for(i = 2; i < items ; i++) {
 323                                         av_push(params, ST(i));
 324                                 }
 325                         }
 326                         RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
 327                         OUTPUT:
 328                         RETVAL
 329
 330 SV *
 331 self (class)
 332                 char* class
 333         CODE:
 334                 RETVAL = Perl_thread_self(class);
 335         OUTPUT:
 336                 RETVAL
 337
 338 int
 339 tid (obj)
 340                 SV *    obj;
 341         CODE:
 342                 RETVAL = Perl_thread_tid(obj);
 343         OUTPUT:
 344         RETVAL
 345
 346 void
 347 join (obj)
 348         SV *    obj
 349         PREINIT:
 350         I32* temp;
 351         PPCODE:
 352         temp = PL_markstack_ptr++;
 353         Perl_thread_join(obj);
 354         if (PL_markstack_ptr != temp) {
 355           /* truly void, because dXSARGS not invoked */
 356           PL_markstack_ptr = temp;
 357           XSRETURN_EMPTY; /* return empty stack */
 358         }
 359         /* must have used dXSARGS; list context implied */
 360         return; /* assume stack size is correct */
 361
 362 void
 363 detach (obj)
 364         SV *    obj
 365         PREINIT:
 366         I32* temp;
 367         PPCODE:
 368         temp = PL_markstack_ptr++;
 369         Perl_thread_detach(obj);
 370         if (PL_markstack_ptr != temp) {
 371           /* truly void, because dXSARGS not invoked */
 372           PL_markstack_ptr = temp;
 373           XSRETURN_EMPTY; /* return empty stack */
 374         }
 375         /* must have used dXSARGS; list context implied */
 376         return; /* assume stack size is correct */
 377
 378 void
 379 DESTROY (obj)
 380         SV *    obj
 381         PREINIT:
 382         I32* temp;
 383         PPCODE:
 384         temp = PL_markstack_ptr++;
 385         Perl_thread_DESTROY(obj);
 386         if (PL_markstack_ptr != temp) {
 387           /* truly void, because dXSARGS not invoked */
 388           PL_markstack_ptr = temp;
 389           XSRETURN_EMPTY; /* return empty stack */
 390         }
 391         /* must have used dXSARGS; list context implied */
 392         return; /* assume stack size is correct */
 393