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