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