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