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