ext/threads/threads.xs

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