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