| 1 | #include "EXTERN.h" |
| 2 | #include "perl.h" |
| 3 | #include "XSUB.h" |
| 4 | |
| 5 | /* Magic signature for Thread's mg_private is "Th" */ |
| 6 | #define Thread_MAGIC_SIGNATURE 0x5468 |
| 7 | |
| 8 | #ifdef __cplusplus |
| 9 | #ifdef I_UNISTD |
| 10 | #include <unistd.h> |
| 11 | #endif |
| 12 | #endif |
| 13 | #include <fcntl.h> |
| 14 | |
| 15 | static int sig_pipe[2]; |
| 16 | |
| 17 | #ifndef THREAD_RET_TYPE |
| 18 | #define THREAD_RET_TYPE void * |
| 19 | #define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x) |
| 20 | #endif |
| 21 | |
| 22 | static void |
| 23 | remove_thread(struct perl_thread *t) |
| 24 | { |
| 25 | #ifdef USE_THREADS |
| 26 | DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), |
| 27 | "%p: remove_thread %p\n", thr, t))); |
| 28 | MUTEX_LOCK(&PL_threads_mutex); |
| 29 | MUTEX_DESTROY(&t->mutex); |
| 30 | PL_nthreads--; |
| 31 | t->prev->next = t->next; |
| 32 | t->next->prev = t->prev; |
| 33 | COND_BROADCAST(&PL_nthreads_cond); |
| 34 | MUTEX_UNLOCK(&PL_threads_mutex); |
| 35 | #endif |
| 36 | } |
| 37 | |
| 38 | static THREAD_RET_TYPE |
| 39 | threadstart(void *arg) |
| 40 | { |
| 41 | #ifdef USE_THREADS |
| 42 | #ifdef FAKE_THREADS |
| 43 | Thread savethread = thr; |
| 44 | LOGOP myop; |
| 45 | dSP; |
| 46 | I32 oldscope = PL_scopestack_ix; |
| 47 | I32 retval; |
| 48 | AV *av; |
| 49 | int i; |
| 50 | |
| 51 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", |
| 52 | thr, SvPEEK(TOPs))); |
| 53 | thr = (Thread) arg; |
| 54 | savemark = TOPMARK; |
| 55 | thr->prev = thr->prev_run = savethread; |
| 56 | thr->next = savethread->next; |
| 57 | thr->next_run = savethread->next_run; |
| 58 | savethread->next = savethread->next_run = thr; |
| 59 | thr->wait_queue = 0; |
| 60 | thr->private = 0; |
| 61 | |
| 62 | /* Now duplicate most of perl_call_sv but with a few twists */ |
| 63 | PL_op = (OP*)&myop; |
| 64 | Zero(PL_op, 1, LOGOP); |
| 65 | myop.op_flags = OPf_STACKED; |
| 66 | myop.op_next = Nullop; |
| 67 | myop.op_flags |= OPf_KNOW; |
| 68 | myop.op_flags |= OPf_WANT_LIST; |
| 69 | PL_op = pp_entersub(ARGS); |
| 70 | DEBUG_S(if (!PL_op) |
| 71 | PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n")); |
| 72 | /* |
| 73 | * When this thread is next scheduled, we start in the right |
| 74 | * place. When the thread runs off the end of the sub, perl.c |
| 75 | * handles things, using savemark to figure out how much of the |
| 76 | * stack is the return value for any join. |
| 77 | */ |
| 78 | thr = savethread; /* back to the old thread */ |
| 79 | return 0; |
| 80 | #else |
| 81 | Thread thr = (Thread) arg; |
| 82 | LOGOP myop; |
| 83 | djSP; |
| 84 | I32 oldmark = TOPMARK; |
| 85 | I32 oldscope = PL_scopestack_ix; |
| 86 | I32 retval; |
| 87 | SV *sv; |
| 88 | AV *av = newAV(); |
| 89 | int i, ret; |
| 90 | dJMPENV; |
| 91 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n", |
| 92 | thr)); |
| 93 | |
| 94 | /* Don't call *anything* requiring dTHR until after SET_THR() */ |
| 95 | /* |
| 96 | * Wait until our creator releases us. If we didn't do this, then |
| 97 | * it would be potentially possible for out thread to carry on and |
| 98 | * do stuff before our creator fills in our "self" field. For example, |
| 99 | * if we went and created another thread which tried to JOIN with us, |
| 100 | * then we'd be in a mess. |
| 101 | */ |
| 102 | MUTEX_LOCK(&thr->mutex); |
| 103 | MUTEX_UNLOCK(&thr->mutex); |
| 104 | |
| 105 | /* |
| 106 | * It's safe to wait until now to set the thread-specific pointer |
| 107 | * from our pthread_t structure to our struct perl_thread, since |
| 108 | * we're the only thread who can get at it anyway. |
| 109 | */ |
| 110 | SET_THR(thr); |
| 111 | |
| 112 | /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ |
| 113 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", |
| 114 | thr, SvPEEK(TOPs))); |
| 115 | |
| 116 | sv = POPs; |
| 117 | PUTBACK; |
| 118 | perl_call_sv(sv, G_ARRAY|G_EVAL); |
| 119 | SPAGAIN; |
| 120 | retval = SP - (PL_stack_base + oldmark); |
| 121 | SP = PL_stack_base + oldmark + 1; |
| 122 | if (SvCUR(thr->errsv)) { |
| 123 | MUTEX_LOCK(&thr->mutex); |
| 124 | thr->flags |= THRf_DID_DIE; |
| 125 | MUTEX_UNLOCK(&thr->mutex); |
| 126 | av_store(av, 0, &PL_sv_no); |
| 127 | av_store(av, 1, newSVsv(thr->errsv)); |
| 128 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n", |
| 129 | thr, SvPV(thr->errsv, PL_na))); |
| 130 | } else { |
| 131 | DEBUG_S(STMT_START { |
| 132 | for (i = 1; i <= retval; i++) { |
| 133 | PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n", |
| 134 | thr, i, SvPEEK(SP[i - 1])); |
| 135 | } |
| 136 | } STMT_END); |
| 137 | av_store(av, 0, &PL_sv_yes); |
| 138 | for (i = 1; i <= retval; i++, SP++) |
| 139 | sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP)); |
| 140 | } |
| 141 | |
| 142 | finishoff: |
| 143 | #if 0 |
| 144 | /* removed for debug */ |
| 145 | SvREFCNT_dec(PL_curstack); |
| 146 | #endif |
| 147 | SvREFCNT_dec(thr->cvcache); |
| 148 | SvREFCNT_dec(thr->threadsv); |
| 149 | SvREFCNT_dec(thr->specific); |
| 150 | SvREFCNT_dec(thr->errsv); |
| 151 | SvREFCNT_dec(thr->errhv); |
| 152 | |
| 153 | /*Safefree(cxstack);*/ |
| 154 | while (PL_curstackinfo->si_next) |
| 155 | PL_curstackinfo = PL_curstackinfo->si_next; |
| 156 | while (PL_curstackinfo) { |
| 157 | PERL_SI *p = PL_curstackinfo->si_prev; |
| 158 | SvREFCNT_dec(PL_curstackinfo->si_stack); |
| 159 | Safefree(PL_curstackinfo->si_cxstack); |
| 160 | Safefree(PL_curstackinfo); |
| 161 | PL_curstackinfo = p; |
| 162 | } |
| 163 | Safefree(PL_markstack); |
| 164 | Safefree(PL_scopestack); |
| 165 | Safefree(PL_savestack); |
| 166 | Safefree(PL_retstack); |
| 167 | Safefree(PL_tmps_stack); |
| 168 | Safefree(PL_ofs); |
| 169 | |
| 170 | SvREFCNT_dec(PL_rs); |
| 171 | SvREFCNT_dec(PL_nrs); |
| 172 | SvREFCNT_dec(PL_statname); |
| 173 | Safefree(PL_screamfirst); |
| 174 | Safefree(PL_screamnext); |
| 175 | Safefree(PL_reg_start_tmp); |
| 176 | SvREFCNT_dec(PL_lastscream); |
| 177 | /*SvREFCNT_dec(PL_defoutgv);*/ |
| 178 | |
| 179 | MUTEX_LOCK(&thr->mutex); |
| 180 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 181 | "%p: threadstart finishing: state is %u\n", |
| 182 | thr, ThrSTATE(thr))); |
| 183 | switch (ThrSTATE(thr)) { |
| 184 | case THRf_R_JOINABLE: |
| 185 | ThrSETSTATE(thr, THRf_ZOMBIE); |
| 186 | MUTEX_UNLOCK(&thr->mutex); |
| 187 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 188 | "%p: R_JOINABLE thread finished\n", thr)); |
| 189 | break; |
| 190 | case THRf_R_JOINED: |
| 191 | ThrSETSTATE(thr, THRf_DEAD); |
| 192 | MUTEX_UNLOCK(&thr->mutex); |
| 193 | remove_thread(thr); |
| 194 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 195 | "%p: R_JOINED thread finished\n", thr)); |
| 196 | break; |
| 197 | case THRf_R_DETACHED: |
| 198 | ThrSETSTATE(thr, THRf_DEAD); |
| 199 | MUTEX_UNLOCK(&thr->mutex); |
| 200 | SvREFCNT_dec(av); |
| 201 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 202 | "%p: DETACHED thread finished\n", thr)); |
| 203 | remove_thread(thr); /* This might trigger main thread to finish */ |
| 204 | break; |
| 205 | default: |
| 206 | MUTEX_UNLOCK(&thr->mutex); |
| 207 | croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr)); |
| 208 | /* NOTREACHED */ |
| 209 | } |
| 210 | return THREAD_RET_CAST(av); /* Available for anyone to join with */ |
| 211 | /* us unless we're detached, in which */ |
| 212 | /* case noone sees the value anyway. */ |
| 213 | #endif |
| 214 | #else |
| 215 | return THREAD_RET_CAST(NULL); |
| 216 | #endif |
| 217 | } |
| 218 | |
| 219 | static SV * |
| 220 | newthread (SV *startsv, AV *initargs, char *classname) |
| 221 | { |
| 222 | #ifdef USE_THREADS |
| 223 | dSP; |
| 224 | Thread savethread; |
| 225 | int i; |
| 226 | SV *sv; |
| 227 | int err; |
| 228 | #ifndef THREAD_CREATE |
| 229 | static pthread_attr_t attr; |
| 230 | static int attr_inited = 0; |
| 231 | sigset_t fullmask, oldmask; |
| 232 | #endif |
| 233 | #ifdef PTHREAD_SETDETACHSTATE_ARG2_POINTER |
| 234 | static int attr_joinable = ATTR_JOINABLE; |
| 235 | #endif |
| 236 | |
| 237 | savethread = thr; |
| 238 | thr = new_struct_thread(thr); |
| 239 | SPAGAIN; |
| 240 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 241 | "%p: newthread (%p), tid is %u, preparing stack\n", |
| 242 | savethread, thr, thr->tid)); |
| 243 | /* The following pushes the arg list and startsv onto the *new* stack */ |
| 244 | PUSHMARK(SP); |
| 245 | /* Could easily speed up the following greatly */ |
| 246 | for (i = 0; i <= AvFILL(initargs); i++) |
| 247 | XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE))); |
| 248 | XPUSHs(SvREFCNT_inc(startsv)); |
| 249 | PUTBACK; |
| 250 | #ifdef THREAD_CREATE |
| 251 | err = THREAD_CREATE(thr, threadstart); |
| 252 | #else |
| 253 | /* On your marks... */ |
| 254 | MUTEX_LOCK(&thr->mutex); |
| 255 | /* Get set... */ |
| 256 | sigfillset(&fullmask); |
| 257 | if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1) |
| 258 | croak("panic: sigprocmask"); |
| 259 | err = 0; |
| 260 | if (!attr_inited) { |
| 261 | attr_inited = 1; |
| 262 | #ifdef OLD_PTHREADS_API |
| 263 | err = pthread_attr_create(&attr); |
| 264 | #else |
| 265 | err = pthread_attr_init(&attr); |
| 266 | #endif |
| 267 | #ifdef OLD_PTHREADS_API |
| 268 | #ifdef VMS |
| 269 | /* This is available with the old pthreads API, but only with */ |
| 270 | /* DecThreads (VMS and Digital Unix (which has and uses the new one)) */ |
| 271 | if (err == 0) |
| 272 | err = pthread_attr_setdetach_np(&attr, ATTR_JOINABLE); |
| 273 | #endif |
| 274 | #else /* !defined(VMS) */ |
| 275 | #ifdef ATTR_JOINABLE |
| 276 | if (err == 0) |
| 277 | err = pthread_attr_setdetachstate(&attr, ATTR_JOINABLE); |
| 278 | #else /* !defined(ATTR_JOINABLE) */ |
| 279 | #ifdef __UNDETACHED |
| 280 | if (err == 0) |
| 281 | err = pthread_attr_setdetachstate(&attr, &__undetached); |
| 282 | #else /* !defined(__UNDETACHED) */ |
| 283 | croak("panic: can't pthread_attr_setdetachstate"); |
| 284 | #endif /* __UNDETACHED */ |
| 285 | #endif /* ATTR_JOINABLE */ |
| 286 | #endif /* VMS */ |
| 287 | #endif /* OLD_PTHREADS_API */ |
| 288 | } |
| 289 | if (err == 0) |
| 290 | #ifdef OLD_PTHREADS_API |
| 291 | err = pthread_create(&thr->self, attr, threadstart, (void*) thr); |
| 292 | #else |
| 293 | err = pthread_create(&thr->self, &attr, threadstart, (void*) thr); |
| 294 | #endif |
| 295 | /* Go */ |
| 296 | MUTEX_UNLOCK(&thr->mutex); |
| 297 | #endif |
| 298 | if (err) { |
| 299 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 300 | "%p: create of %p failed %d\n", |
| 301 | savethread, thr, err)); |
| 302 | /* Thread creation failed--clean up */ |
| 303 | SvREFCNT_dec(thr->cvcache); |
| 304 | remove_thread(thr); |
| 305 | MUTEX_DESTROY(&thr->mutex); |
| 306 | for (i = 0; i <= AvFILL(initargs); i++) |
| 307 | SvREFCNT_dec(*av_fetch(initargs, i, FALSE)); |
| 308 | SvREFCNT_dec(startsv); |
| 309 | return NULL; |
| 310 | } |
| 311 | #ifdef THREAD_POST_CREATE |
| 312 | THREAD_POST_CREATE(thr); |
| 313 | #else |
| 314 | if (sigprocmask(SIG_SETMASK, &oldmask, 0)) |
| 315 | croak("panic: sigprocmask"); |
| 316 | #endif |
| 317 | sv = newSViv(thr->tid); |
| 318 | sv_magic(sv, thr->oursv, '~', 0, 0); |
| 319 | SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; |
| 320 | return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); |
| 321 | #else |
| 322 | croak("No threads in this perl"); |
| 323 | return &PL_sv_undef; |
| 324 | #endif |
| 325 | } |
| 326 | |
| 327 | static Signal_t handle_thread_signal _((int sig)); |
| 328 | |
| 329 | static Signal_t |
| 330 | handle_thread_signal(int sig) |
| 331 | { |
| 332 | unsigned char c = (unsigned char) sig; |
| 333 | /* |
| 334 | * We're not really allowed to call fprintf in a signal handler |
| 335 | * so don't be surprised if this isn't robust while debugging |
| 336 | * with -DL. |
| 337 | */ |
| 338 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 339 | "handle_thread_signal: got signal %d\n", sig);); |
| 340 | write(sig_pipe[1], &c, 1); |
| 341 | } |
| 342 | |
| 343 | MODULE = Thread PACKAGE = Thread |
| 344 | PROTOTYPES: DISABLE |
| 345 | |
| 346 | void |
| 347 | new(classname, startsv, ...) |
| 348 | char * classname |
| 349 | SV * startsv |
| 350 | AV * av = av_make(items - 2, &ST(2)); |
| 351 | PPCODE: |
| 352 | XPUSHs(sv_2mortal(newthread(startsv, av, classname))); |
| 353 | |
| 354 | void |
| 355 | join(t) |
| 356 | Thread t |
| 357 | AV * av = NO_INIT |
| 358 | int i = NO_INIT |
| 359 | PPCODE: |
| 360 | #ifdef USE_THREADS |
| 361 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n", |
| 362 | thr, t, ThrSTATE(t));); |
| 363 | MUTEX_LOCK(&t->mutex); |
| 364 | switch (ThrSTATE(t)) { |
| 365 | case THRf_R_JOINABLE: |
| 366 | case THRf_R_JOINED: |
| 367 | ThrSETSTATE(t, THRf_R_JOINED); |
| 368 | MUTEX_UNLOCK(&t->mutex); |
| 369 | break; |
| 370 | case THRf_ZOMBIE: |
| 371 | ThrSETSTATE(t, THRf_DEAD); |
| 372 | MUTEX_UNLOCK(&t->mutex); |
| 373 | remove_thread(t); |
| 374 | break; |
| 375 | default: |
| 376 | MUTEX_UNLOCK(&t->mutex); |
| 377 | croak("can't join with thread"); |
| 378 | /* NOTREACHED */ |
| 379 | } |
| 380 | JOIN(t, &av); |
| 381 | |
| 382 | if (SvTRUE(*av_fetch(av, 0, FALSE))) { |
| 383 | /* Could easily speed up the following if necessary */ |
| 384 | for (i = 1; i <= AvFILL(av); i++) |
| 385 | XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE))); |
| 386 | } else { |
| 387 | char *mess = SvPV(*av_fetch(av, 1, FALSE), PL_na); |
| 388 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 389 | "%p: join propagating die message: %s\n", |
| 390 | thr, mess)); |
| 391 | croak(mess); |
| 392 | } |
| 393 | #endif |
| 394 | |
| 395 | void |
| 396 | detach(t) |
| 397 | Thread t |
| 398 | CODE: |
| 399 | #ifdef USE_THREADS |
| 400 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n", |
| 401 | thr, t, ThrSTATE(t));); |
| 402 | MUTEX_LOCK(&t->mutex); |
| 403 | switch (ThrSTATE(t)) { |
| 404 | case THRf_R_JOINABLE: |
| 405 | ThrSETSTATE(t, THRf_R_DETACHED); |
| 406 | /* fall through */ |
| 407 | case THRf_R_DETACHED: |
| 408 | DETACH(t); |
| 409 | MUTEX_UNLOCK(&t->mutex); |
| 410 | break; |
| 411 | case THRf_ZOMBIE: |
| 412 | ThrSETSTATE(t, THRf_DEAD); |
| 413 | DETACH(t); |
| 414 | MUTEX_UNLOCK(&t->mutex); |
| 415 | remove_thread(t); |
| 416 | break; |
| 417 | default: |
| 418 | MUTEX_UNLOCK(&t->mutex); |
| 419 | croak("can't detach thread"); |
| 420 | /* NOTREACHED */ |
| 421 | } |
| 422 | #endif |
| 423 | |
| 424 | void |
| 425 | equal(t1, t2) |
| 426 | Thread t1 |
| 427 | Thread t2 |
| 428 | PPCODE: |
| 429 | PUSHs((t1 == t2) ? &PL_sv_yes : &PL_sv_no); |
| 430 | |
| 431 | void |
| 432 | flags(t) |
| 433 | Thread t |
| 434 | PPCODE: |
| 435 | #ifdef USE_THREADS |
| 436 | PUSHs(sv_2mortal(newSViv(t->flags))); |
| 437 | #endif |
| 438 | |
| 439 | void |
| 440 | self(classname) |
| 441 | char * classname |
| 442 | PREINIT: |
| 443 | SV *sv; |
| 444 | PPCODE: |
| 445 | #ifdef USE_THREADS |
| 446 | sv = newSViv(thr->tid); |
| 447 | sv_magic(sv, thr->oursv, '~', 0, 0); |
| 448 | SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; |
| 449 | PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), |
| 450 | gv_stashpv(classname, TRUE)))); |
| 451 | #endif |
| 452 | |
| 453 | U32 |
| 454 | tid(t) |
| 455 | Thread t |
| 456 | CODE: |
| 457 | #ifdef USE_THREADS |
| 458 | MUTEX_LOCK(&t->mutex); |
| 459 | RETVAL = t->tid; |
| 460 | MUTEX_UNLOCK(&t->mutex); |
| 461 | #else |
| 462 | RETVAL = 0; |
| 463 | #endif |
| 464 | OUTPUT: |
| 465 | RETVAL |
| 466 | |
| 467 | void |
| 468 | DESTROY(t) |
| 469 | SV * t |
| 470 | PPCODE: |
| 471 | PUSHs(&PL_sv_yes); |
| 472 | |
| 473 | void |
| 474 | yield() |
| 475 | CODE: |
| 476 | { |
| 477 | #ifdef USE_THREADS |
| 478 | YIELD; |
| 479 | #endif |
| 480 | } |
| 481 | |
| 482 | void |
| 483 | cond_wait(sv) |
| 484 | SV * sv |
| 485 | MAGIC * mg = NO_INIT |
| 486 | CODE: |
| 487 | #ifdef USE_THREADS |
| 488 | if (SvROK(sv)) |
| 489 | sv = SvRV(sv); |
| 490 | |
| 491 | mg = condpair_magic(sv); |
| 492 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv)); |
| 493 | MUTEX_LOCK(MgMUTEXP(mg)); |
| 494 | if (MgOWNER(mg) != thr) { |
| 495 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 496 | croak("cond_wait for lock that we don't own\n"); |
| 497 | } |
| 498 | MgOWNER(mg) = 0; |
| 499 | COND_SIGNAL(MgOWNERCONDP(mg)); |
| 500 | COND_WAIT(MgCONDP(mg), MgMUTEXP(mg)); |
| 501 | while (MgOWNER(mg)) |
| 502 | COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); |
| 503 | MgOWNER(mg) = thr; |
| 504 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 505 | #endif |
| 506 | |
| 507 | void |
| 508 | cond_signal(sv) |
| 509 | SV * sv |
| 510 | MAGIC * mg = NO_INIT |
| 511 | CODE: |
| 512 | #ifdef USE_THREADS |
| 513 | if (SvROK(sv)) |
| 514 | sv = SvRV(sv); |
| 515 | |
| 516 | mg = condpair_magic(sv); |
| 517 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv)); |
| 518 | MUTEX_LOCK(MgMUTEXP(mg)); |
| 519 | if (MgOWNER(mg) != thr) { |
| 520 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 521 | croak("cond_signal for lock that we don't own\n"); |
| 522 | } |
| 523 | COND_SIGNAL(MgCONDP(mg)); |
| 524 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 525 | #endif |
| 526 | |
| 527 | void |
| 528 | cond_broadcast(sv) |
| 529 | SV * sv |
| 530 | MAGIC * mg = NO_INIT |
| 531 | CODE: |
| 532 | #ifdef USE_THREADS |
| 533 | if (SvROK(sv)) |
| 534 | sv = SvRV(sv); |
| 535 | |
| 536 | mg = condpair_magic(sv); |
| 537 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n", |
| 538 | thr, sv)); |
| 539 | MUTEX_LOCK(MgMUTEXP(mg)); |
| 540 | if (MgOWNER(mg) != thr) { |
| 541 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 542 | croak("cond_broadcast for lock that we don't own\n"); |
| 543 | } |
| 544 | COND_BROADCAST(MgCONDP(mg)); |
| 545 | MUTEX_UNLOCK(MgMUTEXP(mg)); |
| 546 | #endif |
| 547 | |
| 548 | void |
| 549 | list(classname) |
| 550 | char * classname |
| 551 | PREINIT: |
| 552 | Thread t; |
| 553 | AV * av; |
| 554 | SV ** svp; |
| 555 | int n = 0; |
| 556 | PPCODE: |
| 557 | #ifdef USE_THREADS |
| 558 | av = newAV(); |
| 559 | /* |
| 560 | * Iterate until we have enough dynamic storage for all threads. |
| 561 | * We mustn't do any allocation while holding threads_mutex though. |
| 562 | */ |
| 563 | MUTEX_LOCK(&PL_threads_mutex); |
| 564 | do { |
| 565 | n = PL_nthreads; |
| 566 | MUTEX_UNLOCK(&PL_threads_mutex); |
| 567 | if (AvFILL(av) < n - 1) { |
| 568 | int i = AvFILL(av); |
| 569 | for (i = AvFILL(av); i < n - 1; i++) { |
| 570 | SV *sv = newSViv(0); /* fill in tid later */ |
| 571 | sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */ |
| 572 | av_push(av, sv_bless(newRV_noinc(sv), |
| 573 | gv_stashpv(classname, TRUE))); |
| 574 | |
| 575 | } |
| 576 | } |
| 577 | MUTEX_LOCK(&PL_threads_mutex); |
| 578 | } while (n < PL_nthreads); |
| 579 | n = PL_nthreads; /* Get the final correct value */ |
| 580 | |
| 581 | /* |
| 582 | * At this point, there's enough room to fill in av. |
| 583 | * Note that we are holding threads_mutex so the list |
| 584 | * won't change out from under us but all the remaining |
| 585 | * processing is "fast" (no blocking, malloc etc.) |
| 586 | */ |
| 587 | t = thr; |
| 588 | svp = AvARRAY(av); |
| 589 | do { |
| 590 | SV *sv = (SV*)SvRV(*svp); |
| 591 | sv_setiv(sv, t->tid); |
| 592 | SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv); |
| 593 | SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED; |
| 594 | SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; |
| 595 | t = t->next; |
| 596 | svp++; |
| 597 | } while (t != thr); |
| 598 | /* */ |
| 599 | MUTEX_UNLOCK(&PL_threads_mutex); |
| 600 | /* Truncate any unneeded slots in av */ |
| 601 | av_fill(av, n - 1); |
| 602 | /* Finally, push all the new objects onto the stack and drop av */ |
| 603 | EXTEND(SP, n); |
| 604 | for (svp = AvARRAY(av); n > 0; n--, svp++) |
| 605 | PUSHs(*svp); |
| 606 | (void)sv_2mortal((SV*)av); |
| 607 | #endif |
| 608 | |
| 609 | |
| 610 | MODULE = Thread PACKAGE = Thread::Signal |
| 611 | |
| 612 | void |
| 613 | kill_sighandler_thread() |
| 614 | PPCODE: |
| 615 | write(sig_pipe[1], "\0", 1); |
| 616 | PUSHs(&PL_sv_yes); |
| 617 | |
| 618 | void |
| 619 | init_thread_signals() |
| 620 | PPCODE: |
| 621 | PL_sighandlerp = handle_thread_signal; |
| 622 | if (pipe(sig_pipe) == -1) |
| 623 | XSRETURN_UNDEF; |
| 624 | PUSHs(&PL_sv_yes); |
| 625 | |
| 626 | void |
| 627 | await_signal() |
| 628 | PREINIT: |
| 629 | unsigned char c; |
| 630 | SSize_t ret; |
| 631 | CODE: |
| 632 | do { |
| 633 | ret = read(sig_pipe[0], &c, 1); |
| 634 | } while (ret == -1 && errno == EINTR); |
| 635 | if (ret == -1) |
| 636 | croak("panic: await_signal"); |
| 637 | ST(0) = sv_newmortal(); |
| 638 | if (ret) |
| 639 | sv_setsv(ST(0), c ? psig_ptr[c] : &PL_sv_no); |
| 640 | DEBUG_S(PerlIO_printf(PerlIO_stderr(), |
| 641 | "await_signal returning %s\n", SvPEEK(ST(0)));); |
| 642 | |
| 643 | MODULE = Thread PACKAGE = Thread::Specific |
| 644 | |
| 645 | void |
| 646 | data(classname = "Thread::Specific") |
| 647 | char * classname |
| 648 | PPCODE: |
| 649 | #ifdef USE_THREADS |
| 650 | if (AvFILL(thr->specific) == -1) { |
| 651 | GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV); |
| 652 | av_store(thr->specific, 0, newRV((SV*)GvHV(gv))); |
| 653 | } |
| 654 | XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE))); |
| 655 | #endif |