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         PerlIO_flush((PerlIO*)NULL);
  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_flags(current_perl, temp_store,params, SV_GMAGIC);
 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_flags(current_perl,temp_store, init_function, SV_GMAGIC);
 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_flags(thread->interp,temp_store, &PL_sv_undef, SV_GMAGIC);
 133
 134         temp_store = Perl_get_sv(thread->interp,"threads::calltempstore",FALSE);
 135         Perl_sv_setsv_flags(thread->interp,temp_store, &PL_sv_undef, SV_GMAGIC);
 136
 137         PERL_SET_CONTEXT(current_perl);
 138
 139         temp_store = Perl_get_sv(current_perl,"threads::paramtempstore",FALSE);
 140         Perl_sv_setsv_flags(current_perl, temp_store, &PL_sv_undef, SV_GMAGIC);
 141
 142         temp_store = Perl_get_sv(current_perl,"threads::calltempstore",FALSE);
 143         Perl_sv_setsv_flags(current_perl, temp_store, &PL_sv_undef, SV_GMAGIC);
 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         {
 160           static pthread_attr_t attr;
 161           static int attr_inited = 0;
 162           sigset_t fullmask, oldmask;
 163           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
 164           if (!attr_inited) {
 165             attr_inited = 1;
 166             pthread_attr_init(&attr);
 167           }
 168 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
 169             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 170 #  endif
 171 #  ifdef THREAD_CREATE_NEEDS_STACK
 172             if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
 173               croak("panic: pthread_attr_setstacksize failed");
 174 #  endif
 175
 176 #ifdef OLD_PTHREADS_API
 177           pthread_create( &thread->thr, attr, Perl_thread_run, (void *)thread);
 178 #else
 179           pthread_create( &thread->thr, &attr, Perl_thread_run, (void *)thread);
 180 #endif
 181         }
 182 #endif
 183         MUTEX_UNLOCK(&create_mutex);
 184
 185         return obj_ref;
 186 }
 187
 188 /*
 189  * returns the id of the thread
 190  */
 191 I32 Perl_thread_tid (SV* obj) {
 192         ithread* thread;
 193         if(!SvROK(obj)) {
 194                 obj = Perl_thread_self(SvPV_nolen(obj));
 195                 thread = (ithread*)SvIV(SvRV(obj));
 196                 SvREFCNT_dec(obj);
 197         } else {
 198                 thread = (ithread*)SvIV(SvRV(obj));
 199         }
 200         return thread->tid;
 201 }
 202
 203 SV* Perl_thread_self (char* class) {
 204         dTHX;
 205         SV*      obj_ref;
 206         SV*      obj;
 207         SV*     thread_tid_ptr;
 208         SV*     thread_ptr;
 209         HE*     thread_entry;
 210         void*   id;
 211         PERL_THREAD_GETSPECIFIC(self_key,id);
 212         SHAREDSvLOCK(threads);
 213         SHAREDSvEDIT(threads);
 214
 215         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(id));
 216
 217         thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
 218                                          (HV*) SHAREDSvGET(threads),
 219                                          thread_tid_ptr, 0,0);
 220         thread_ptr = HeVAL(thread_entry);
 221         SvREFCNT_dec(thread_tid_ptr);
 222         SHAREDSvRELEASE(threads);
 223         SHAREDSvUNLOCK(threads);
 224
 225         obj_ref = newSViv(0);
 226         obj = newSVrv(obj_ref, class);
 227         sv_setsv(obj, thread_ptr);
 228         SvREADONLY_on(obj);
 229         return obj_ref;
 230 }
 231
 232 /*
 233  * joins the thread this code needs to take the returnvalue from the
 234  * call_sv and send it back */
 235
 236 void Perl_thread_join(SV* obj) {
 237         ithread* thread = (ithread*)SvIV(SvRV(obj));
 238 #ifdef WIN32
 239         DWORD waitcode;
 240         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 241 #else
 242         void *retval;
 243         pthread_join(thread->thr,&retval);
 244 #endif
 245 }
 246
 247 /* detaches a thread
 248  * needs to better clean up memory */
 249
 250 void Perl_thread_detach(SV* obj) {
 251         ithread* thread = (ithread*)SvIV(SvRV(obj));
 252         MUTEX_LOCK(&thread->mutex);
 253         thread->detached = 1;
 254         PERL_THREAD_DETACH(thread->thr);
 255         MUTEX_UNLOCK(&thread->mutex);
 256 }
 257
 258 void Perl_thread_DESTROY (SV* obj) {
 259         ithread* thread = (ithread*)SvIV(SvRV(obj));
 260
 261         MUTEX_LOCK(&thread->mutex);
 262         thread->count--;
 263         MUTEX_UNLOCK(&thread->mutex);
 264         Perl_thread_destruct(thread);
 265 }
 266
 267 void Perl_thread_destruct (ithread* thread) {
 268         return;
 269         MUTEX_LOCK(&thread->mutex);
 270         if(thread->count != 0) {
 271                 MUTEX_UNLOCK(&thread->mutex);
 272                 return;
 273         }
 274         MUTEX_UNLOCK(&thread->mutex);
 275         /* it is safe noone is holding a ref to this */
 276         /*printf("proper destruction!\n");*/
 277 }
 278
 279 MODULE = threads                PACKAGE = threads
 280 BOOT:
 281         Perl_sharedsv_init(aTHX);
 282         PL_perl_destruct_level = 2;
 283         threads = Perl_sharedsv_new(aTHX);
 284         SHAREDSvEDIT(threads);
 285         SHAREDSvGET(threads) = (SV *)newHV();
 286         SHAREDSvRELEASE(threads);
 287         {
 288
 289
 290             SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
 291             SV* temp2 = newSViv((IV)PL_sharedsv_space );
 292             sv_setsv( temp , temp2 );
 293         }
 294         {
 295                 ithread* thread = malloc(sizeof(ithread));
 296                 SV* thread_tid_ptr;
 297                 SV* thread_ptr;
 298                 MUTEX_INIT(&thread->mutex);
 299                 thread->tid = 0;
 300 #ifdef WIN32
 301                 thread->thr = GetCurrentThreadId();
 302 #else
 303                 thread->thr = pthread_self();
 304 #endif
 305                 SHAREDSvEDIT(threads);
 306                 PERL_THREAD_ALLOC_SPECIFIC(self_key);
 307                 PERL_THREAD_SETSPECIFIC(self_key,0);
 308                 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, 0);
 309                 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
 310                 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
 311                 SvREFCNT_dec(thread_tid_ptr);
 312                 SHAREDSvRELEASE(threads);
 313         }
 314         MUTEX_INIT(&create_mutex);
 315
 316 PROTOTYPES: DISABLE
 317
 318 SV *
 319 create (class, function_to_call, ...)
 320         char *  class
 321         SV *    function_to_call
 322                 CODE:
 323                         AV* params = newAV();
 324                         if(items > 2) {
 325                                 int i;
 326                                 for(i = 2; i < items ; i++) {
 327                                         av_push(params, ST(i));
 328                                 }
 329                         }
 330                         RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
 331                         OUTPUT:
 332                         RETVAL
 333
 334 SV *
 335 self (class)
 336                 char* class
 337         CODE:
 338                 RETVAL = Perl_thread_self(class);
 339         OUTPUT:
 340                 RETVAL
 341
 342 int
 343 tid (obj)
 344                 SV *    obj;
 345         CODE:
 346                 RETVAL = Perl_thread_tid(obj);
 347         OUTPUT:
 348         RETVAL
 349
 350 void
 351 join (obj)
 352         SV *    obj
 353         PREINIT:
 354         I32* temp;
 355         PPCODE:
 356         temp = PL_markstack_ptr++;
 357         Perl_thread_join(obj);
 358         if (PL_markstack_ptr != temp) {
 359           /* truly void, because dXSARGS not invoked */
 360           PL_markstack_ptr = temp;
 361           XSRETURN_EMPTY; /* return empty stack */
 362         }
 363         /* must have used dXSARGS; list context implied */
 364         return; /* assume stack size is correct */
 365
 366 void
 367 detach (obj)
 368         SV *    obj
 369         PREINIT:
 370         I32* temp;
 371         PPCODE:
 372         temp = PL_markstack_ptr++;
 373         Perl_thread_detach(obj);
 374         if (PL_markstack_ptr != temp) {
 375           /* truly void, because dXSARGS not invoked */
 376           PL_markstack_ptr = temp;
 377           XSRETURN_EMPTY; /* return empty stack */
 378         }
 379         /* must have used dXSARGS; list context implied */
 380         return; /* assume stack size is correct */
 381
 382 void
 383 DESTROY (obj)
 384         SV *    obj
 385         PREINIT:
 386         I32* temp;
 387         PPCODE:
 388         temp = PL_markstack_ptr++;
 389         Perl_thread_DESTROY(obj);
 390         if (PL_markstack_ptr != temp) {
 391           /* truly void, because dXSARGS not invoked */
 392           PL_markstack_ptr = temp;
 393           XSRETURN_EMPTY; /* return empty stack */
 394         }
 395         /* must have used dXSARGS; list context implied */
 396         return; /* assume stack size is correct */
 397