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