Commit | Line | Data |
---|---|---|
68795e93 NIS |
1 | #define PERL_NO_GET_CONTEXT |
2 | #include "EXTERN.h" | |
3 | #include "perl.h" | |
4 | #include "XSUB.h" | |
0f1612a7 JH |
5 | #ifdef HAS_PPPORT_H |
6 | # define NEED_newRV_noinc | |
7 | # define NEED_sv_2pv_nolen | |
8 | # include "ppport.h" | |
9 | # include "threads.h" | |
10 | #endif | |
68795e93 | 11 | |
73e09c8f JH |
12 | #ifdef USE_ITHREADS |
13 | ||
c05ae023 | 14 | |
68795e93 NIS |
15 | #ifdef WIN32 |
16 | #include <windows.h> | |
17 | #include <win32thread.h> | |
68795e93 | 18 | #else |
5c728af0 IZ |
19 | #ifdef OS2 |
20 | typedef perl_os_thread pthread_t; | |
21 | #else | |
68795e93 | 22 | #include <pthread.h> |
5c728af0 | 23 | #endif |
68795e93 | 24 | #include <thread.h> |
68795e93 NIS |
25 | #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) |
26 | #ifdef OLD_PTHREADS_API | |
27 | #define PERL_THREAD_DETACH(t) pthread_detach(&(t)) | |
68795e93 NIS |
28 | #else |
29 | #define PERL_THREAD_DETACH(t) pthread_detach((t)) | |
c05ae023 | 30 | #endif /* OLD_PTHREADS_API */ |
467f3f08 | 31 | #endif |
68795e93 | 32 | |
c05ae023 AB |
33 | |
34 | ||
35 | ||
62375a60 NIS |
36 | /* Values for 'state' member */ |
37 | #define PERL_ITHR_JOINABLE 0 | |
38 | #define PERL_ITHR_DETACHED 1 | |
62375a60 | 39 | #define PERL_ITHR_JOINED 2 |
9feacc09 | 40 | #define PERL_ITHR_FINISHED 4 |
62375a60 | 41 | |
68795e93 | 42 | typedef struct ithread_s { |
6dfd2d05 JH |
43 | struct ithread_s *next; /* Next thread in the list */ |
44 | struct ithread_s *prev; /* Prev thread in the list */ | |
68795e93 | 45 | PerlInterpreter *interp; /* The threads interpreter */ |
f4cc38af | 46 | UV tid; /* Threads module's thread id */ |
6dfd2d05 | 47 | perl_mutex mutex; /* Mutex for updating things in this struct */ |
9feacc09 JH |
48 | int count; /* How many SVs have a reference to us */ |
49 | int state; /* Are we detached ? */ | |
a446a88f | 50 | int gimme; /* Context of create */ |
68795e93 | 51 | SV* init_function; /* Code to run */ |
6dfd2d05 | 52 | SV* params; /* Args to pass function */ |
68795e93 NIS |
53 | #ifdef WIN32 |
54 | DWORD thr; /* OS's idea if thread id */ | |
55 | HANDLE handle; /* OS's waitable handle */ | |
56 | #else | |
57 | pthread_t thr; /* OS's handle for the thread */ | |
58 | #endif | |
59 | } ithread; | |
60 | ||
628ab322 DM |
61 | #define MY_CXT_KEY "threads::_guts" XS_VERSION |
62 | ||
63 | typedef struct { | |
64 | ithread *thread; | |
65 | } my_cxt_t; | |
66 | ||
67 | START_MY_CXT | |
68 | ||
69 | ||
f4cc38af | 70 | static ithread *threads; |
68795e93 | 71 | |
58c2ef19 | 72 | static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/ |
68795e93 | 73 | |
f4cc38af | 74 | static UV tid_counter = 0; |
f4cc38af | 75 | static IV active_threads = 0; |
c05ae023 AB |
76 | |
77 | ||
f4cc38af | 78 | static void |
bcd9ca9b | 79 | S_ithread_set (pTHX_ ithread* thread) |
c05ae023 | 80 | { |
628ab322 DM |
81 | dMY_CXT; |
82 | MY_CXT.thread = thread; | |
c05ae023 AB |
83 | } |
84 | ||
f4cc38af | 85 | static ithread* |
bcd9ca9b | 86 | S_ithread_get (pTHX) { |
628ab322 DM |
87 | dMY_CXT; |
88 | return MY_CXT.thread; | |
c05ae023 AB |
89 | } |
90 | ||
91 | ||
2e676467 DM |
92 | /* free any data (such as the perl interpreter) attached to an |
93 | * ithread structure. This is a bit like undef on SVs, where the SV | |
94 | * isn't freed, but the PVX is. | |
95 | * Must be called with thread->mutex already held | |
96 | */ | |
97 | ||
98 | static void | |
41fc7aad | 99 | S_ithread_clear(pTHX_ ithread* thread) |
2e676467 DM |
100 | { |
101 | PerlInterpreter *interp; | |
102 | assert(thread->state & PERL_ITHR_FINISHED && | |
103 | (thread->state & PERL_ITHR_DETACHED || | |
104 | thread->state & PERL_ITHR_JOINED)); | |
105 | ||
106 | interp = thread->interp; | |
107 | if (interp) { | |
108 | dTHXa(interp); | |
109 | ithread* current_thread; | |
110 | #ifdef OEMVS | |
111 | void *ptr; | |
112 | #endif | |
113 | PERL_SET_CONTEXT(interp); | |
bcd9ca9b JH |
114 | current_thread = S_ithread_get(aTHX); |
115 | S_ithread_set(aTHX_ thread); | |
2e676467 DM |
116 | |
117 | SvREFCNT_dec(thread->params); | |
118 | ||
119 | thread->params = Nullsv; | |
120 | perl_destruct(interp); | |
121 | thread->interp = NULL; | |
122 | } | |
123 | if (interp) | |
124 | perl_free(interp); | |
125 | PERL_SET_CONTEXT(aTHX); | |
126 | } | |
127 | ||
68795e93 NIS |
128 | |
129 | /* | |
2e676467 | 130 | * free an ithread structure and any attached data if its count == 0 |
68795e93 | 131 | */ |
bcd9ca9b | 132 | static void |
385d56e4 | 133 | S_ithread_destruct (pTHX_ ithread* thread) |
68795e93 | 134 | { |
385d56e4 JH |
135 | #ifdef WIN32 |
136 | HANDLE handle; | |
137 | #endif | |
138 | ||
68795e93 | 139 | MUTEX_LOCK(&thread->mutex); |
385d56e4 JH |
140 | |
141 | /* Thread is still in use */ | |
68795e93 NIS |
142 | if (thread->count != 0) { |
143 | MUTEX_UNLOCK(&thread->mutex); | |
d1400e48 | 144 | return; |
68795e93 | 145 | } |
bcd9ca9b | 146 | |
385d56e4 | 147 | MUTEX_LOCK(&create_destruct_mutex); |
9feacc09 JH |
148 | /* Main thread (0) is immortal and should never get here */ |
149 | assert(thread->tid != 0); | |
150 | ||
151 | /* Remove from circular list of threads */ | |
385d56e4 JH |
152 | thread->next->prev = thread->prev; |
153 | thread->prev->next = thread->next; | |
154 | thread->next = NULL; | |
155 | thread->prev = NULL; | |
62375a60 | 156 | MUTEX_UNLOCK(&create_destruct_mutex); |
c2f2a82b | 157 | |
385d56e4 | 158 | /* Thread is now disowned */ |
41fc7aad | 159 | S_ithread_clear(aTHX_ thread); |
385d56e4 JH |
160 | |
161 | #ifdef WIN32 | |
162 | handle = thread->handle; | |
163 | thread->handle = NULL; | |
164 | #endif | |
d1400e48 | 165 | MUTEX_UNLOCK(&thread->mutex); |
1c3adb19 | 166 | MUTEX_DESTROY(&thread->mutex); |
385d56e4 | 167 | |
c7667023 | 168 | #ifdef WIN32 |
385d56e4 JH |
169 | if (handle) |
170 | CloseHandle(handle); | |
c7667023 | 171 | #endif |
385d56e4 JH |
172 | |
173 | /* Call PerlMemShared_free() in the context of the "first" interpreter | |
174 | * per http://www.nntp.perl.org/group/perl.perl5.porters/110772 | |
175 | */ | |
176 | aTHX = PL_curinterp; | |
1c3adb19 | 177 | PerlMemShared_free(thread); |
68795e93 NIS |
178 | } |
179 | ||
62375a60 NIS |
180 | int |
181 | Perl_ithread_hook(pTHX) | |
182 | { | |
183 | int veto_cleanup = 0; | |
184 | MUTEX_LOCK(&create_destruct_mutex); | |
185 | if (aTHX == PL_curinterp && active_threads != 1) { | |
4447dfc1 TP |
186 | if (ckWARN_d(WARN_THREADS)) |
187 | Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", | |
f4cc38af | 188 | active_threads); |
62375a60 NIS |
189 | veto_cleanup = 1; |
190 | } | |
191 | MUTEX_UNLOCK(&create_destruct_mutex); | |
192 | return veto_cleanup; | |
193 | } | |
194 | ||
bcd9ca9b JH |
195 | static void |
196 | S_ithread_detach(pTHX_ ithread *thread) | |
62375a60 NIS |
197 | { |
198 | MUTEX_LOCK(&thread->mutex); | |
199 | if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { | |
200 | thread->state |= PERL_ITHR_DETACHED; | |
201 | #ifdef WIN32 | |
202 | CloseHandle(thread->handle); | |
203 | thread->handle = 0; | |
204 | #else | |
205 | PERL_THREAD_DETACH(thread->thr); | |
206 | #endif | |
207 | } | |
208 | if ((thread->state & PERL_ITHR_FINISHED) && | |
209 | (thread->state & PERL_ITHR_DETACHED)) { | |
210 | MUTEX_UNLOCK(&thread->mutex); | |
385d56e4 | 211 | S_ithread_destruct(aTHX_ thread); |
62375a60 NIS |
212 | } |
213 | else { | |
214 | MUTEX_UNLOCK(&thread->mutex); | |
215 | } | |
216 | } | |
68795e93 NIS |
217 | |
218 | /* MAGIC (in mg.h sense) hooks */ | |
219 | ||
220 | int | |
221 | ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) | |
222 | { | |
223 | ithread *thread = (ithread *) mg->mg_ptr; | |
45977657 | 224 | SvIV_set(sv, PTR2IV(thread)); |
68795e93 NIS |
225 | SvIOK_on(sv); |
226 | return 0; | |
227 | } | |
228 | ||
229 | int | |
230 | ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) | |
231 | { | |
232 | ithread *thread = (ithread *) mg->mg_ptr; | |
233 | MUTEX_LOCK(&thread->mutex); | |
68795e93 | 234 | thread->count--; |
62375a60 | 235 | if (thread->count == 0) { |
1c3adb19 AB |
236 | if(thread->state & PERL_ITHR_FINISHED && |
237 | (thread->state & PERL_ITHR_DETACHED || | |
238 | thread->state & PERL_ITHR_JOINED)) | |
239 | { | |
240 | MUTEX_UNLOCK(&thread->mutex); | |
385d56e4 | 241 | S_ithread_destruct(aTHX_ thread); |
1c3adb19 | 242 | } |
1ea20f42 AB |
243 | else { |
244 | MUTEX_UNLOCK(&thread->mutex); | |
245 | } | |
62375a60 NIS |
246 | } |
247 | else { | |
248 | MUTEX_UNLOCK(&thread->mutex); | |
249 | } | |
68795e93 NIS |
250 | return 0; |
251 | } | |
252 | ||
253 | int | |
254 | ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) | |
255 | { | |
256 | ithread *thread = (ithread *) mg->mg_ptr; | |
257 | MUTEX_LOCK(&thread->mutex); | |
68795e93 NIS |
258 | thread->count++; |
259 | MUTEX_UNLOCK(&thread->mutex); | |
260 | return 0; | |
261 | } | |
262 | ||
263 | MGVTBL ithread_vtbl = { | |
264 | ithread_mg_get, /* get */ | |
265 | 0, /* set */ | |
266 | 0, /* len */ | |
267 | 0, /* clear */ | |
268 | ithread_mg_free, /* free */ | |
269 | 0, /* copy */ | |
270 | ithread_mg_dup /* dup */ | |
271 | }; | |
272 | ||
47ba8780 | 273 | |
47ba8780 | 274 | /* |
b1edfb69 | 275 | * Starts executing the thread. Needs to clean up memory a tad better. |
68795e93 | 276 | * Passed as the C level function to run in the new thread |
b1edfb69 | 277 | */ |
47ba8780 AB |
278 | |
279 | #ifdef WIN32 | |
f4cc38af | 280 | static THREAD_RET_TYPE |
bcd9ca9b | 281 | S_ithread_run(LPVOID arg) { |
47ba8780 | 282 | #else |
f4cc38af | 283 | static void* |
bcd9ca9b | 284 | S_ithread_run(void * arg) { |
47ba8780 | 285 | #endif |
5b414d21 | 286 | ithread* thread = (ithread*) arg; |
47ba8780 | 287 | dTHXa(thread->interp); |
47ba8780 | 288 | PERL_SET_CONTEXT(thread->interp); |
bcd9ca9b | 289 | S_ithread_set(aTHX_ thread); |
47ba8780 | 290 | |
68795e93 NIS |
291 | #if 0 |
292 | /* Far from clear messing with ->thr child-side is a good idea */ | |
293 | MUTEX_LOCK(&thread->mutex); | |
47ba8780 AB |
294 | #ifdef WIN32 |
295 | thread->thr = GetCurrentThreadId(); | |
296 | #else | |
297 | thread->thr = pthread_self(); | |
298 | #endif | |
68795e93 NIS |
299 | MUTEX_UNLOCK(&thread->mutex); |
300 | #endif | |
47ba8780 | 301 | |
47ba8780 | 302 | PL_perl_destruct_level = 2; |
4f896ddc | 303 | |
47ba8780 | 304 | { |
68795e93 | 305 | AV* params = (AV*) SvRV(thread->params); |
f4cc38af JH |
306 | int len = (int)av_len(params)+1; |
307 | int ii; | |
47ba8780 | 308 | dSP; |
47ba8780 AB |
309 | ENTER; |
310 | SAVETMPS; | |
311 | PUSHMARK(SP); | |
f4cc38af | 312 | for(ii = 0; ii < len; ii++) { |
68795e93 | 313 | XPUSHs(av_shift(params)); |
47ba8780 AB |
314 | } |
315 | PUTBACK; | |
f4cc38af | 316 | len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); |
0405e91e | 317 | |
68795e93 | 318 | SPAGAIN; |
f4cc38af | 319 | for (ii=len-1; ii >= 0; ii--) { |
e1c44605 | 320 | SV *sv = POPs; |
f4cc38af | 321 | av_store(params, ii, SvREFCNT_inc(sv)); |
a446a88f | 322 | } |
4447dfc1 | 323 | if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { |
6b3c7930 | 324 | Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV); |
a446a88f | 325 | } |
47ba8780 AB |
326 | FREETMPS; |
327 | LEAVE; | |
68795e93 | 328 | SvREFCNT_dec(thread->init_function); |
47ba8780 AB |
329 | } |
330 | ||
fd58862f | 331 | PerlIO_flush((PerlIO*)NULL); |
68795e93 | 332 | MUTEX_LOCK(&thread->mutex); |
62375a60 NIS |
333 | thread->state |= PERL_ITHR_FINISHED; |
334 | ||
335 | if (thread->state & PERL_ITHR_DETACHED) { | |
47ba8780 | 336 | MUTEX_UNLOCK(&thread->mutex); |
385d56e4 | 337 | S_ithread_destruct(aTHX_ thread); |
47ba8780 | 338 | } else { |
62375a60 NIS |
339 | MUTEX_UNLOCK(&thread->mutex); |
340 | } | |
91604d21 AB |
341 | MUTEX_LOCK(&create_destruct_mutex); |
342 | active_threads--; | |
91604d21 AB |
343 | MUTEX_UNLOCK(&create_destruct_mutex); |
344 | ||
47ba8780 AB |
345 | #ifdef WIN32 |
346 | return (DWORD)0; | |
e8f2bb9a JH |
347 | #else |
348 | return 0; | |
47ba8780 | 349 | #endif |
68795e93 NIS |
350 | } |
351 | ||
f4cc38af | 352 | static SV * |
68795e93 NIS |
353 | ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) |
354 | { | |
355 | SV *sv; | |
356 | MAGIC *mg; | |
357 | if (inc) { | |
358 | MUTEX_LOCK(&thread->mutex); | |
359 | thread->count++; | |
68795e93 NIS |
360 | MUTEX_UNLOCK(&thread->mutex); |
361 | } | |
362 | if (!obj) | |
363 | obj = newSV(0); | |
364 | sv = newSVrv(obj,classname); | |
365 | sv_setiv(sv,PTR2IV(thread)); | |
366 | mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0); | |
367 | mg->mg_flags |= MGf_DUP; | |
368 | SvREADONLY_on(sv); | |
369 | return obj; | |
370 | } | |
47ba8780 | 371 | |
f4cc38af | 372 | static ithread * |
68795e93 NIS |
373 | SV_to_ithread(pTHX_ SV *sv) |
374 | { | |
68795e93 NIS |
375 | if (SvROK(sv)) |
376 | { | |
c05ae023 | 377 | return INT2PTR(ithread*, SvIV(SvRV(sv))); |
68795e93 NIS |
378 | } |
379 | else | |
380 | { | |
bcd9ca9b | 381 | return S_ithread_get(aTHX); |
68795e93 | 382 | } |
47ba8780 AB |
383 | } |
384 | ||
47ba8780 | 385 | /* |
6dfd2d05 | 386 | * ithread->create(); ( aka ithread->new() ) |
68795e93 | 387 | * Called in context of parent thread |
b1edfb69 | 388 | */ |
47ba8780 | 389 | |
f4cc38af | 390 | static SV * |
bcd9ca9b | 391 | S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) |
68795e93 NIS |
392 | { |
393 | ithread* thread; | |
394 | CLONE_PARAMS clone_param; | |
bcd9ca9b | 395 | ithread* current_thread = S_ithread_get(aTHX); |
3b1c3273 AB |
396 | |
397 | SV** tmps_tmp = PL_tmps_stack; | |
f4cc38af | 398 | IV tmps_ix = PL_tmps_ix; |
d94006e8 | 399 | #ifndef WIN32 |
9feacc09 JH |
400 | int rc_stack_size = 0; |
401 | int rc_thread_create = 0; | |
d94006e8 | 402 | #endif |
3b1c3273 | 403 | |
c05ae023 | 404 | |
58c2ef19 | 405 | MUTEX_LOCK(&create_destruct_mutex); |
8f77bfdb | 406 | thread = (ithread *) PerlMemShared_malloc(sizeof(ithread)); |
8043fdaf NC |
407 | if (!thread) { |
408 | MUTEX_UNLOCK(&create_destruct_mutex); | |
409 | PerlLIO_write(PerlIO_fileno(Perl_error_log), | |
410 | PL_no_mem, strlen(PL_no_mem)); | |
411 | my_exit(1); | |
412 | } | |
68795e93 | 413 | Zero(thread,1,ithread); |
385d56e4 JH |
414 | |
415 | /* Add to threads list */ | |
68795e93 NIS |
416 | thread->next = threads; |
417 | thread->prev = threads->prev; | |
f42ad631 | 418 | threads->prev = thread; |
68795e93 | 419 | thread->prev->next = thread; |
385d56e4 | 420 | |
68795e93 NIS |
421 | /* Set count to 1 immediately in case thread exits before |
422 | * we return to caller ! | |
423 | */ | |
424 | thread->count = 1; | |
425 | MUTEX_INIT(&thread->mutex); | |
426 | thread->tid = tid_counter++; | |
a446a88f | 427 | thread->gimme = GIMME_V; |
4f896ddc | 428 | |
68795e93 NIS |
429 | /* "Clone" our interpreter into the thread's interpreter |
430 | * This gives thread access to "static data" and code. | |
431 | */ | |
47ba8780 | 432 | |
68795e93 | 433 | PerlIO_flush((PerlIO*)NULL); |
bcd9ca9b | 434 | S_ithread_set(aTHX_ thread); |
3b1c3273 | 435 | |
9c98058e AB |
436 | SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct |
437 | value */ | |
438 | PL_srand_called = FALSE; /* Set it to false so we can detect | |
439 | if it gets set during the clone */ | |
3b1c3273 | 440 | |
47ba8780 | 441 | #ifdef WIN32 |
68795e93 | 442 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
47ba8780 | 443 | #else |
68795e93 | 444 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
47ba8780 | 445 | #endif |
ba14dd9a | 446 | /* perl_clone leaves us in new interpreter's context. |
c8dae523 | 447 | As it is tricky to spot an implicit aTHX, create a new scope |
a446a88f | 448 | with aTHX matching the context for the duration of |
ba14dd9a NIS |
449 | our work for new interpreter. |
450 | */ | |
451 | { | |
452 | dTHXa(thread->interp); | |
9c98058e | 453 | |
628ab322 DM |
454 | MY_CXT_CLONE; |
455 | ||
58c2ef19 | 456 | /* Here we remove END blocks since they should only run |
62375a60 | 457 | in the thread they are created |
58c2ef19 NIS |
458 | */ |
459 | SvREFCNT_dec(PL_endav); | |
460 | PL_endav = newAV(); | |
d1400e48 | 461 | clone_param.flags = 0; |
ba14dd9a NIS |
462 | thread->init_function = sv_dup(init_function, &clone_param); |
463 | if (SvREFCNT(thread->init_function) == 0) { | |
464 | SvREFCNT_inc(thread->init_function); | |
d1400e48 | 465 | } |
3b1c3273 AB |
466 | |
467 | ||
ba14dd9a NIS |
468 | |
469 | thread->params = sv_dup(params, &clone_param); | |
470 | SvREFCNT_inc(thread->params); | |
3b1c3273 AB |
471 | |
472 | ||
473 | /* The code below checks that anything living on | |
474 | the tmps stack and has been cloned (so it lives in the | |
475 | ptr_table) has a refcount higher than 0 | |
476 | ||
477 | If the refcount is 0 it means that a something on the | |
478 | stack/context was holding a reference to it and | |
479 | since we init_stacks() in perl_clone that won't get | |
480 | cleaned and we will get a leaked scalar. | |
481 | The reason it was cloned was that it lived on the | |
482 | @_ stack. | |
483 | ||
484 | Example of this can be found in bugreport 15837 | |
485 | where calls in the parameter list end up as a temp | |
486 | ||
487 | One could argue that this fix should be in perl_clone | |
488 | */ | |
489 | ||
490 | ||
491 | while (tmps_ix > 0) { | |
492 | SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); | |
493 | tmps_ix--; | |
494 | if (sv && SvREFCNT(sv) == 0) { | |
495 | SvREFCNT_inc(sv); | |
496 | SvREFCNT_dec(sv); | |
497 | } | |
498 | } | |
499 | ||
500 | ||
501 | ||
ba14dd9a NIS |
502 | SvTEMP_off(thread->init_function); |
503 | ptr_table_free(PL_ptr_table); | |
504 | PL_ptr_table = NULL; | |
ffb29f90 | 505 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
ba14dd9a | 506 | } |
bcd9ca9b | 507 | S_ithread_set(aTHX_ current_thread); |
68795e93 | 508 | PERL_SET_CONTEXT(aTHX); |
47ba8780 | 509 | |
68795e93 | 510 | /* Start the thread */ |
47ba8780 AB |
511 | |
512 | #ifdef WIN32 | |
bcd9ca9b | 513 | thread->handle = CreateThread(NULL, 0, S_ithread_run, |
47ba8780 | 514 | (LPVOID)thread, 0, &thread->thr); |
82c40bf6 | 515 | #else |
fa26028c AB |
516 | { |
517 | static pthread_attr_t attr; | |
518 | static int attr_inited = 0; | |
fa26028c AB |
519 | static int attr_joinable = PTHREAD_CREATE_JOINABLE; |
520 | if (!attr_inited) { | |
521 | attr_inited = 1; | |
522 | pthread_attr_init(&attr); | |
523 | } | |
524 | # ifdef PTHREAD_ATTR_SETDETACHSTATE | |
525 | PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); | |
526 | # endif | |
3eb37d38 | 527 | # ifdef THREAD_CREATE_NEEDS_STACK |
9feacc09 | 528 | rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK); |
3eb37d38 AB |
529 | # endif |
530 | ||
9feacc09 | 531 | if (! rc_stack_size) { |
3ad0b7d6 | 532 | #ifdef OLD_PTHREADS_API |
9feacc09 | 533 | rc_thread_create = pthread_create( &thread->thr, attr, |
bcd9ca9b | 534 | S_ithread_run, (void *)thread); |
47ba8780 | 535 | #else |
58d975c3 | 536 | # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) |
47cb5ff9 | 537 | pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM ); |
19a077f6 | 538 | # endif |
9feacc09 | 539 | rc_thread_create = pthread_create( &thread->thr, &attr, |
bcd9ca9b | 540 | S_ithread_run, (void *)thread); |
47ba8780 | 541 | #endif |
9feacc09 | 542 | } |
3ad0b7d6 | 543 | } |
82c40bf6 | 544 | #endif |
bcd9ca9b | 545 | |
9feacc09 | 546 | /* Check for errors */ |
d94006e8 | 547 | #ifdef WIN32 |
9feacc09 | 548 | if (thread->handle == NULL) { |
d94006e8 | 549 | #else |
9feacc09 | 550 | if (rc_stack_size || rc_thread_create) { |
d94006e8 | 551 | #endif |
d94006e8 NC |
552 | MUTEX_UNLOCK(&create_destruct_mutex); |
553 | sv_2mortal(params); | |
385d56e4 | 554 | S_ithread_destruct(aTHX_ thread); |
d94006e8 | 555 | #ifndef WIN32 |
9feacc09 JH |
556 | if (ckWARN_d(WARN_THREADS)) { |
557 | # ifdef THREAD_CREATE_NEEDS_STACK | |
558 | if (rc_stack_size) | |
559 | Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", (IV)THREAD_CREATE_NEEDS_STACK, rc_stack_size); | |
560 | else | |
561 | # endif | |
562 | Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); | |
563 | } | |
d94006e8 NC |
564 | #endif |
565 | return &PL_sv_undef; | |
566 | } | |
58c2ef19 NIS |
567 | active_threads++; |
568 | MUTEX_UNLOCK(&create_destruct_mutex); | |
95393226 | 569 | sv_2mortal(params); |
3b1c3273 | 570 | |
68795e93 NIS |
571 | return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); |
572 | } | |
47ba8780 | 573 | |
f4cc38af | 574 | static SV* |
bcd9ca9b | 575 | S_ithread_self (pTHX_ SV *obj, char* Class) |
68795e93 | 576 | { |
bcd9ca9b | 577 | ithread *thread = S_ithread_get(aTHX); |
fe53aa5b JH |
578 | if (thread) |
579 | return ithread_to_SV(aTHX_ obj, thread, Class, TRUE); | |
580 | else | |
581 | Perl_croak(aTHX_ "panic: cannot find thread data"); | |
c5661c80 | 582 | return NULL; /* silence compiler warning */ |
47ba8780 AB |
583 | } |
584 | ||
47ba8780 | 585 | |
f4cc38af JH |
586 | /* Joins the thread. |
587 | * This code takes the return value from the call_sv and sends it back. | |
588 | */ | |
589 | static AV* | |
bcd9ca9b | 590 | S_ithread_join(pTHX_ SV *obj) |
68795e93 NIS |
591 | { |
592 | ithread *thread = SV_to_ithread(aTHX_ obj); | |
593 | MUTEX_LOCK(&thread->mutex); | |
62375a60 | 594 | if (thread->state & PERL_ITHR_DETACHED) { |
a446a88f NIS |
595 | MUTEX_UNLOCK(&thread->mutex); |
596 | Perl_croak(aTHX_ "Cannot join a detached thread"); | |
597 | } | |
62375a60 | 598 | else if (thread->state & PERL_ITHR_JOINED) { |
a446a88f NIS |
599 | MUTEX_UNLOCK(&thread->mutex); |
600 | Perl_croak(aTHX_ "Thread already joined"); | |
601 | } | |
602 | else { | |
e1c44605 | 603 | AV* retparam; |
47ba8780 AB |
604 | #ifdef WIN32 |
605 | DWORD waitcode; | |
47ba8780 AB |
606 | #else |
607 | void *retval; | |
47ba8780 | 608 | #endif |
47ba8780 | 609 | MUTEX_UNLOCK(&thread->mutex); |
68795e93 NIS |
610 | #ifdef WIN32 |
611 | waitcode = WaitForSingleObject(thread->handle, INFINITE); | |
c7667023 KC |
612 | CloseHandle(thread->handle); |
613 | thread->handle = 0; | |
68795e93 NIS |
614 | #else |
615 | pthread_join(thread->thr,&retval); | |
616 | #endif | |
47ba8780 | 617 | MUTEX_LOCK(&thread->mutex); |
e1c44605 | 618 | |
62375a60 | 619 | /* sv_dup over the args */ |
e1c44605 | 620 | { |
1d784c90 | 621 | ithread* current_thread; |
62375a60 | 622 | AV* params = (AV*) SvRV(thread->params); |
b23f1a86 | 623 | PerlInterpreter *other_perl = thread->interp; |
e1c44605 | 624 | CLONE_PARAMS clone_params; |
3275ba96 | 625 | clone_params.stashes = newAV(); |
3ae345e3 | 626 | clone_params.flags = CLONEf_JOIN_IN; |
e1c44605 | 627 | PL_ptr_table = ptr_table_new(); |
bcd9ca9b JH |
628 | current_thread = S_ithread_get(aTHX); |
629 | S_ithread_set(aTHX_ thread); | |
b23f1a86 DM |
630 | /* ensure 'meaningful' addresses retain their meaning */ |
631 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); | |
632 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); | |
633 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); | |
0405e91e | 634 | |
767c1403 | 635 | #if 0 |
0405e91e AB |
636 | { |
637 | I32 len = av_len(params)+1; | |
638 | I32 i; | |
639 | for(i = 0; i < len; i++) { | |
767c1403 | 640 | sv_dump(SvRV(AvARRAY(params)[i])); |
0405e91e AB |
641 | } |
642 | } | |
767c1403 | 643 | #endif |
e1c44605 | 644 | retparam = (AV*) sv_dup((SV*)params, &clone_params); |
b4cb676b | 645 | #if 0 |
0405e91e AB |
646 | { |
647 | I32 len = av_len(retparam)+1; | |
648 | I32 i; | |
649 | for(i = 0; i < len; i++) { | |
b4cb676b | 650 | sv_dump(SvRV(AvARRAY(retparam)[i])); |
0405e91e AB |
651 | } |
652 | } | |
b4cb676b | 653 | #endif |
bcd9ca9b | 654 | S_ithread_set(aTHX_ current_thread); |
3275ba96 | 655 | SvREFCNT_dec(clone_params.stashes); |
e1c44605 AB |
656 | SvREFCNT_inc(retparam); |
657 | ptr_table_free(PL_ptr_table); | |
658 | PL_ptr_table = NULL; | |
659 | ||
660 | } | |
6dfd2d05 | 661 | /* We are finished with it */ |
62375a60 | 662 | thread->state |= PERL_ITHR_JOINED; |
41fc7aad | 663 | S_ithread_clear(aTHX_ thread); |
47ba8780 | 664 | MUTEX_UNLOCK(&thread->mutex); |
57b48062 | 665 | |
e1c44605 | 666 | return retparam; |
68795e93 | 667 | } |
e1c44605 | 668 | return (AV*)NULL; |
47ba8780 AB |
669 | } |
670 | ||
f4cc38af | 671 | static void |
bcd9ca9b | 672 | S_ithread_DESTROY(pTHX_ SV *sv) |
68795e93 NIS |
673 | { |
674 | ithread *thread = SV_to_ithread(aTHX_ sv); | |
68795e93 NIS |
675 | sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar); |
676 | } | |
8222d950 | 677 | |
73e09c8f | 678 | #endif /* USE_ITHREADS */ |
e1c44605 | 679 | |
68795e93 NIS |
680 | MODULE = threads PACKAGE = threads PREFIX = ithread_ |
681 | PROTOTYPES: DISABLE | |
8222d950 | 682 | |
73e09c8f JH |
683 | #ifdef USE_ITHREADS |
684 | ||
68795e93 | 685 | void |
f4cc38af JH |
686 | ithread_create(...) |
687 | PREINIT: | |
688 | char *classname; | |
689 | SV *function_to_call; | |
690 | AV *params; | |
691 | int ii; | |
692 | CODE: | |
693 | if (items < 2) | |
694 | Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); | |
695 | ||
696 | classname = (char *)SvPV_nolen(ST(0)); | |
697 | function_to_call = ST(1); | |
698 | ||
699 | /* Function args */ | |
700 | params = newAV(); | |
701 | if (items > 2) { | |
702 | for (ii=2; ii < items; ii++) { | |
703 | av_push(params, SvREFCNT_inc(ST(ii))); | |
704 | } | |
705 | } | |
706 | ||
707 | /* Create thread */ | |
bcd9ca9b | 708 | ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv, |
f4cc38af JH |
709 | classname, |
710 | function_to_call, | |
711 | newRV_noinc((SV*)params))); | |
712 | /* XSRETURN(1); - implied */ | |
713 | ||
8222d950 | 714 | |
68795e93 | 715 | void |
f4cc38af JH |
716 | ithread_list(...) |
717 | PREINIT: | |
718 | char *classname; | |
719 | ithread *thr; | |
720 | int list_context; | |
721 | IV count = 0; | |
722 | PPCODE: | |
723 | /* Class method only */ | |
724 | if (SvROK(ST(0))) | |
725 | Perl_croak(aTHX_ "Usage: threads->list()"); | |
726 | classname = (char *)SvPV_nolen(ST(0)); | |
727 | ||
728 | /* Calling context */ | |
729 | list_context = (GIMME_V == G_ARRAY); | |
730 | ||
731 | /* Walk through threads list */ | |
732 | MUTEX_LOCK(&create_destruct_mutex); | |
733 | for (thr = threads->next; | |
734 | thr != threads; | |
735 | thr = thr->next) | |
736 | { | |
737 | /* Ignore detached or joined threads */ | |
738 | if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { | |
739 | continue; | |
740 | } | |
741 | /* Push object on stack if list context */ | |
742 | if (list_context) { | |
743 | XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE))); | |
744 | } | |
745 | count++; | |
746 | } | |
747 | MUTEX_UNLOCK(&create_destruct_mutex); | |
748 | /* If scalar context, send back count */ | |
749 | if (! list_context) { | |
750 | XSRETURN_IV(count); | |
751 | } | |
678a9b6c AB |
752 | |
753 | ||
754 | void | |
f4cc38af JH |
755 | ithread_self(...) |
756 | PREINIT: | |
757 | char *classname; | |
758 | CODE: | |
759 | /* Class method only */ | |
760 | if (SvROK(ST(0))) | |
761 | Perl_croak(aTHX_ "Usage: threads->self()"); | |
762 | classname = (char *)SvPV_nolen(ST(0)); | |
763 | ||
bcd9ca9b | 764 | ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname)); |
f4cc38af | 765 | /* XSRETURN(1); - implied */ |
47ba8780 | 766 | |
47ba8780 AB |
767 | |
768 | void | |
f4cc38af JH |
769 | ithread_tid(...) |
770 | PREINIT: | |
771 | ithread *thread; | |
772 | CODE: | |
773 | thread = SV_to_ithread(aTHX_ ST(0)); | |
774 | XST_mUV(0, thread->tid); | |
775 | /* XSRETURN(1); - implied */ | |
776 | ||
e1c44605 | 777 | |
f9dff5f5 | 778 | void |
f4cc38af JH |
779 | ithread_join(...) |
780 | PREINIT: | |
781 | AV *params; | |
782 | int len; | |
783 | int ii; | |
784 | PPCODE: | |
785 | /* Object method only */ | |
786 | if (! sv_isobject(ST(0))) | |
787 | Perl_croak(aTHX_ "Usage: $thr->join()"); | |
788 | ||
789 | /* Join thread and get return values */ | |
bcd9ca9b | 790 | params = S_ithread_join(aTHX_ ST(0)); |
f4cc38af JH |
791 | if (! params) { |
792 | XSRETURN_UNDEF; | |
793 | } | |
794 | ||
795 | /* Put return values on stack */ | |
796 | len = (int)AvFILL(params); | |
797 | for (ii=0; ii <= len; ii++) { | |
798 | SV* param = av_shift(params); | |
799 | XPUSHs(sv_2mortal(param)); | |
800 | } | |
801 | ||
802 | /* Free return value array */ | |
803 | SvREFCNT_dec(params); | |
804 | ||
805 | ||
806 | void | |
807 | ithread_yield(...) | |
808 | CODE: | |
809 | YIELD; | |
810 | ||
811 | ||
812 | void | |
813 | ithread_detach(...) | |
814 | PREINIT: | |
815 | ithread *thread; | |
816 | CODE: | |
817 | thread = SV_to_ithread(aTHX_ ST(0)); | |
bcd9ca9b | 818 | S_ithread_detach(aTHX_ thread); |
f4cc38af | 819 | |
47ba8780 AB |
820 | |
821 | void | |
f4cc38af JH |
822 | ithread_DESTROY(...) |
823 | CODE: | |
bcd9ca9b | 824 | S_ithread_DESTROY(aTHX_ ST(0)); |
f4cc38af JH |
825 | |
826 | ||
827 | void | |
828 | ithread_equal(...) | |
829 | CODE: | |
830 | /* Compares TIDs to determine thread equality. | |
831 | * Return 0 on false for backward compatibility. | |
832 | */ | |
833 | if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { | |
834 | ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
835 | ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); | |
836 | if (thr1->tid == thr2->tid) { | |
837 | XST_mYES(0); | |
838 | } else { | |
839 | XST_mIV(0, 0); | |
840 | } | |
841 | } else { | |
842 | XST_mIV(0, 0); | |
843 | } | |
844 | /* XSRETURN(1); - implied */ | |
845 | ||
47ba8780 | 846 | |
47ba8780 | 847 | void |
f4cc38af JH |
848 | ithread_object(...) |
849 | PREINIT: | |
850 | char *classname; | |
851 | UV tid; | |
852 | ithread *thr; | |
853 | int found = 0; | |
854 | CODE: | |
855 | /* Class method only */ | |
856 | if (SvROK(ST(0))) | |
857 | Perl_croak(aTHX_ "Usage: threads->object($tid)"); | |
858 | classname = (char *)SvPV_nolen(ST(0)); | |
859 | ||
860 | if ((items < 2) || ! SvOK(ST(1))) { | |
861 | XSRETURN_UNDEF; | |
862 | } | |
863 | ||
864 | tid = SvUV(ST(1)); | |
865 | ||
866 | /* Walk through threads list */ | |
867 | MUTEX_LOCK(&create_destruct_mutex); | |
868 | for (thr = threads->next; | |
869 | thr != threads; | |
870 | thr = thr->next) | |
871 | { | |
872 | /* Look for TID, but ignore detached or joined threads */ | |
873 | if ((thr->tid != tid) || | |
874 | (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) | |
875 | { | |
876 | continue; | |
877 | } | |
878 | /* Put object on stack */ | |
879 | ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)); | |
880 | found = 1; | |
881 | break; | |
882 | } | |
883 | MUTEX_UNLOCK(&create_destruct_mutex); | |
884 | if (! found) { | |
885 | XSRETURN_UNDEF; | |
886 | } | |
887 | /* XSRETURN(1); - implied */ | |
888 | ||
889 | ||
890 | void | |
891 | ithread__handle(...); | |
892 | PREINIT: | |
893 | ithread *thread; | |
894 | CODE: | |
895 | thread = SV_to_ithread(aTHX_ ST(0)); | |
896 | #ifdef WIN32 | |
897 | XST_mUV(0, PTR2UV(thread->handle)); | |
898 | #else | |
75ba4ae2 | 899 | XST_mUV(0, PTR2UV(&thread->thr)); |
f4cc38af JH |
900 | #endif |
901 | /* XSRETURN(1); - implied */ | |
68795e93 | 902 | |
73e09c8f JH |
903 | #endif /* USE_ITHREADS */ |
904 | ||
68795e93 NIS |
905 | BOOT: |
906 | { | |
73e09c8f | 907 | #ifdef USE_ITHREADS |
9feacc09 JH |
908 | /* The 'main' thread is thread 0. |
909 | * It is detached (unjoinable) and immortal. | |
910 | */ | |
68795e93 | 911 | ithread* thread; |
9feacc09 JH |
912 | MY_CXT_INIT; |
913 | ||
e1c44605 | 914 | PL_perl_destruct_level = 2; |
58c2ef19 NIS |
915 | MUTEX_INIT(&create_destruct_mutex); |
916 | MUTEX_LOCK(&create_destruct_mutex); | |
62375a60 | 917 | PL_threadhook = &Perl_ithread_hook; |
8f77bfdb | 918 | thread = (ithread *) PerlMemShared_malloc(sizeof(ithread)); |
8043fdaf NC |
919 | if (!thread) { |
920 | PerlLIO_write(PerlIO_fileno(Perl_error_log), | |
921 | PL_no_mem, strlen(PL_no_mem)); | |
922 | my_exit(1); | |
923 | } | |
68795e93 NIS |
924 | Zero(thread,1,ithread); |
925 | PL_perl_destruct_level = 2; | |
926 | MUTEX_INIT(&thread->mutex); | |
385d56e4 JH |
927 | |
928 | /* Head of the threads list */ | |
68795e93 NIS |
929 | threads = thread; |
930 | thread->next = thread; | |
931 | thread->prev = thread; | |
385d56e4 | 932 | |
68795e93 | 933 | thread->interp = aTHX; |
6dfd2d05 | 934 | thread->count = 1; /* Immortal. */ |
68795e93 | 935 | thread->tid = tid_counter++; |
58c2ef19 | 936 | active_threads++; |
1fea7ed3 | 937 | thread->state = PERL_ITHR_DETACHED; |
68795e93 NIS |
938 | #ifdef WIN32 |
939 | thread->thr = GetCurrentThreadId(); | |
940 | #else | |
941 | thread->thr = pthread_self(); | |
942 | #endif | |
62375a60 | 943 | |
bcd9ca9b | 944 | S_ithread_set(aTHX_ thread); |
58c2ef19 | 945 | MUTEX_UNLOCK(&create_destruct_mutex); |
73e09c8f | 946 | #endif /* USE_ITHREADS */ |
68795e93 NIS |
947 | } |
948 |