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