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