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