line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* |
2
|
|
|
|
|
|
* This file was generated automatically by ExtUtils::ParseXS version 3.22 from the |
3
|
|
|
|
|
|
* contents of threads.xs. Do not edit this file, edit threads.xs instead. |
4
|
|
|
|
|
|
* |
5
|
|
|
|
|
|
* ANY CHANGES MADE HERE WILL BE LOST! |
6
|
|
|
|
|
|
* |
7
|
|
|
|
|
|
*/ |
8
|
|
|
|
|
|
|
9
|
|
|
|
|
|
#line 1 "threads.xs" |
10
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
11
|
|
|
|
|
|
/* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include. |
12
|
|
|
|
|
|
* It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but |
13
|
|
|
|
|
|
* that's ok as that compiler makes no use of that symbol anyway */ |
14
|
|
|
|
|
|
#if defined(WIN32) && defined(__MINGW32__) && !defined(__MINGW64__) |
15
|
|
|
|
|
|
# define USE_NO_MINGW_SETJMP_TWO_ARGS 1 |
16
|
|
|
|
|
|
#endif |
17
|
|
|
|
|
|
#include "EXTERN.h" |
18
|
|
|
|
|
|
#include "perl.h" |
19
|
|
|
|
|
|
#include "XSUB.h" |
20
|
|
|
|
|
|
/* Workaround for XSUB.h bug under WIN32 */ |
21
|
|
|
|
|
|
#ifdef WIN32 |
22
|
|
|
|
|
|
# undef setjmp |
23
|
|
|
|
|
|
# if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__)) |
24
|
|
|
|
|
|
# define setjmp(x) _setjmp(x) |
25
|
|
|
|
|
|
# endif |
26
|
|
|
|
|
|
# if defined(__MINGW64__) |
27
|
|
|
|
|
|
# define setjmp(x) _setjmpex((x), mingw_getsp()) |
28
|
|
|
|
|
|
# endif |
29
|
|
|
|
|
|
#endif |
30
|
|
|
|
|
|
#ifdef HAS_PPPORT_H |
31
|
|
|
|
|
|
# define NEED_PL_signals |
32
|
|
|
|
|
|
# define NEED_newRV_noinc |
33
|
|
|
|
|
|
# define NEED_sv_2pv_flags |
34
|
|
|
|
|
|
# include "ppport.h" |
35
|
|
|
|
|
|
# include "threads.h" |
36
|
|
|
|
|
|
#endif |
37
|
|
|
|
|
|
#ifndef sv_dup_inc |
38
|
|
|
|
|
|
# define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) |
39
|
|
|
|
|
|
#endif |
40
|
|
|
|
|
|
|
41
|
|
|
|
|
|
#ifdef USE_ITHREADS |
42
|
|
|
|
|
|
|
43
|
|
|
|
|
|
#ifdef WIN32 |
44
|
|
|
|
|
|
# include |
45
|
|
|
|
|
|
/* Supposed to be in Winbase.h */ |
46
|
|
|
|
|
|
# ifndef STACK_SIZE_PARAM_IS_A_RESERVATION |
47
|
|
|
|
|
|
# define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000 |
48
|
|
|
|
|
|
# endif |
49
|
|
|
|
|
|
# include |
50
|
|
|
|
|
|
#else |
51
|
|
|
|
|
|
# ifdef OS2 |
52
|
|
|
|
|
|
typedef perl_os_thread pthread_t; |
53
|
|
|
|
|
|
# else |
54
|
|
|
|
|
|
# include |
55
|
|
|
|
|
|
# endif |
56
|
|
|
|
|
|
# include |
57
|
|
|
|
|
|
# define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) |
58
|
|
|
|
|
|
# ifdef OLD_PTHREADS_API |
59
|
|
|
|
|
|
# define PERL_THREAD_DETACH(t) pthread_detach(&(t)) |
60
|
|
|
|
|
|
# else |
61
|
|
|
|
|
|
# define PERL_THREAD_DETACH(t) pthread_detach((t)) |
62
|
|
|
|
|
|
# endif |
63
|
|
|
|
|
|
#endif |
64
|
|
|
|
|
|
#if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM) |
65
|
|
|
|
|
|
# include |
66
|
|
|
|
|
|
#endif |
67
|
|
|
|
|
|
|
68
|
|
|
|
|
|
/* Values for 'state' member */ |
69
|
|
|
|
|
|
#define PERL_ITHR_DETACHED 1 /* Thread has been detached */ |
70
|
|
|
|
|
|
#define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */ |
71
|
|
|
|
|
|
#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */ |
72
|
|
|
|
|
|
#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */ |
73
|
|
|
|
|
|
#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ |
74
|
|
|
|
|
|
#define PERL_ITHR_DIED 32 /* Thread finished by dying */ |
75
|
|
|
|
|
|
|
76
|
|
|
|
|
|
#define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED) |
77
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
79
|
|
|
|
|
|
typedef struct _ithread { |
80
|
|
|
|
|
|
struct _ithread *next; /* Next thread in the list */ |
81
|
|
|
|
|
|
struct _ithread *prev; /* Prev thread in the list */ |
82
|
|
|
|
|
|
PerlInterpreter *interp; /* The threads interpreter */ |
83
|
|
|
|
|
|
UV tid; /* Threads module's thread id */ |
84
|
|
|
|
|
|
perl_mutex mutex; /* Mutex for updating things in this struct */ |
85
|
|
|
|
|
|
int count; /* Reference count. See S_ithread_create. */ |
86
|
|
|
|
|
|
int state; /* Detached, joined, finished, etc. */ |
87
|
|
|
|
|
|
int gimme; /* Context of create */ |
88
|
|
|
|
|
|
SV *init_function; /* Code to run */ |
89
|
|
|
|
|
|
AV *params; /* Args to pass function */ |
90
|
|
|
|
|
|
#ifdef WIN32 |
91
|
|
|
|
|
|
DWORD thr; /* OS's idea if thread id */ |
92
|
|
|
|
|
|
HANDLE handle; /* OS's waitable handle */ |
93
|
|
|
|
|
|
#else |
94
|
|
|
|
|
|
pthread_t thr; /* OS's handle for the thread */ |
95
|
|
|
|
|
|
#endif |
96
|
|
|
|
|
|
IV stack_size; |
97
|
|
|
|
|
|
SV *err; /* Error from abnormally terminated thread */ |
98
|
|
|
|
|
|
char *err_class; /* Error object's classname if applicable */ |
99
|
|
|
|
|
|
#ifndef WIN32 |
100
|
|
|
|
|
|
sigset_t initial_sigmask; /* Thread wakes up with signals blocked */ |
101
|
|
|
|
|
|
#endif |
102
|
|
|
|
|
|
} ithread; |
103
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
105
|
|
|
|
|
|
#define MY_CXT_KEY "threads::_cxt" XS_VERSION |
106
|
|
|
|
|
|
|
107
|
|
|
|
|
|
typedef struct { |
108
|
|
|
|
|
|
/* Used by Perl interpreter for thread context switching */ |
109
|
|
|
|
|
|
ithread *context; |
110
|
|
|
|
|
|
} my_cxt_t; |
111
|
|
|
|
|
|
|
112
|
|
|
|
|
|
START_MY_CXT |
113
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
115
|
|
|
|
|
|
#define MY_POOL_KEY "threads::_pool" XS_VERSION |
116
|
|
|
|
|
|
|
117
|
|
|
|
|
|
typedef struct { |
118
|
|
|
|
|
|
/* Structure for 'main' thread |
119
|
|
|
|
|
|
* Also forms the 'base' for the doubly-linked list of threads */ |
120
|
|
|
|
|
|
ithread main_thread; |
121
|
|
|
|
|
|
|
122
|
|
|
|
|
|
/* Protects the creation and destruction of threads*/ |
123
|
|
|
|
|
|
perl_mutex create_destruct_mutex; |
124
|
|
|
|
|
|
|
125
|
|
|
|
|
|
UV tid_counter; |
126
|
|
|
|
|
|
IV joinable_threads; |
127
|
|
|
|
|
|
IV running_threads; |
128
|
|
|
|
|
|
IV detached_threads; |
129
|
|
|
|
|
|
IV total_threads; |
130
|
|
|
|
|
|
IV default_stack_size; |
131
|
|
|
|
|
|
IV page_size; |
132
|
|
|
|
|
|
} my_pool_t; |
133
|
|
|
|
|
|
|
134
|
|
|
|
|
|
#define dMY_POOL \ |
135
|
|
|
|
|
|
SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, \ |
136
|
|
|
|
|
|
sizeof(MY_POOL_KEY)-1, TRUE); \ |
137
|
|
|
|
|
|
my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv)) |
138
|
|
|
|
|
|
|
139
|
|
|
|
|
|
#define MY_POOL (*my_poolp) |
140
|
|
|
|
|
|
|
141
|
|
|
|
|
|
#ifndef WIN32 |
142
|
|
|
|
|
|
/* Block most signals for calling thread, setting the old signal mask to |
143
|
|
|
|
|
|
* oldmask, if it is not NULL */ |
144
|
|
|
|
|
|
STATIC int |
145
|
|
|
|
|
|
S_block_most_signals(sigset_t *oldmask) |
146
|
|
|
|
|
|
{ |
147
|
|
|
|
|
|
sigset_t newmask; |
148
|
|
|
|
|
|
|
149
|
|
|
|
|
|
sigfillset(&newmask); |
150
|
|
|
|
|
|
/* Don't block certain "important" signals (stolen from mg.c) */ |
151
|
|
|
|
|
|
#ifdef SIGILL |
152
|
|
|
|
|
|
sigdelset(&newmask, SIGILL); |
153
|
|
|
|
|
|
#endif |
154
|
|
|
|
|
|
#ifdef SIGBUS |
155
|
|
|
|
|
|
sigdelset(&newmask, SIGBUS); |
156
|
|
|
|
|
|
#endif |
157
|
|
|
|
|
|
#ifdef SIGSEGV |
158
|
|
|
|
|
|
sigdelset(&newmask, SIGSEGV); |
159
|
|
|
|
|
|
#endif |
160
|
|
|
|
|
|
|
161
|
|
|
|
|
|
#if defined(VMS) |
162
|
|
|
|
|
|
/* no per-thread blocking available */ |
163
|
|
|
|
|
|
return sigprocmask(SIG_BLOCK, &newmask, oldmask); |
164
|
|
|
|
|
|
#else |
165
|
|
|
|
|
|
return pthread_sigmask(SIG_BLOCK, &newmask, oldmask); |
166
|
|
|
|
|
|
#endif /* VMS */ |
167
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
169
|
|
|
|
|
|
/* Set the signal mask for this thread to newmask */ |
170
|
|
|
|
|
|
STATIC int |
171
|
|
|
|
|
|
S_set_sigmask(sigset_t *newmask) |
172
|
|
|
|
|
|
{ |
173
|
|
|
|
|
|
#if defined(VMS) |
174
|
|
|
|
|
|
return sigprocmask(SIG_SETMASK, newmask, NULL); |
175
|
|
|
|
|
|
#else |
176
|
|
|
|
|
|
return pthread_sigmask(SIG_SETMASK, newmask, NULL); |
177
|
|
|
|
|
|
#endif /* VMS */ |
178
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
#endif /* WIN32 */ |
180
|
|
|
|
|
|
|
181
|
|
|
|
|
|
/* Used by Perl interpreter for thread context switching */ |
182
|
|
|
|
|
|
STATIC void |
183
|
|
|
|
|
|
S_ithread_set(pTHX_ ithread *thread) |
184
|
|
|
|
|
|
{ |
185
|
|
|
|
|
|
dMY_CXT; |
186
|
|
|
|
|
|
MY_CXT.context = thread; |
187
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
189
|
|
|
|
|
|
STATIC ithread * |
190
|
|
|
|
|
|
S_ithread_get(pTHX) |
191
|
|
|
|
|
|
{ |
192
|
|
|
|
|
|
dMY_CXT; |
193
|
|
|
|
|
|
return (MY_CXT.context); |
194
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
197
|
|
|
|
|
|
/* Free any data (such as the Perl interpreter) attached to an ithread |
198
|
|
|
|
|
|
* structure. This is a bit like undef on SVs, where the SV isn't freed, |
199
|
|
|
|
|
|
* but the PVX is. Must be called with thread->mutex already locked. Also, |
200
|
|
|
|
|
|
* must be called with MY_POOL.create_destruct_mutex unlocked as destruction |
201
|
|
|
|
|
|
* of the interpreter can lead to recursive destruction calls that could |
202
|
|
|
|
|
|
* lead to a deadlock on that mutex. |
203
|
|
|
|
|
|
*/ |
204
|
|
|
|
|
|
STATIC void |
205
|
|
|
|
|
|
S_ithread_clear(pTHX_ ithread *thread) |
206
|
|
|
|
|
|
{ |
207
|
|
|
|
|
|
PerlInterpreter *interp; |
208
|
|
|
|
|
|
#ifndef WIN32 |
209
|
|
|
|
|
|
sigset_t origmask; |
210
|
|
|
|
|
|
#endif |
211
|
|
|
|
|
|
|
212
|
|
|
|
|
|
assert(((thread->state & PERL_ITHR_FINISHED) && |
213
|
|
|
|
|
|
(thread->state & PERL_ITHR_UNCALLABLE)) |
214
|
|
|
|
|
|
|| |
215
|
|
|
|
|
|
(thread->state & PERL_ITHR_NONVIABLE)); |
216
|
|
|
|
|
|
|
217
|
|
|
|
|
|
#ifndef WIN32 |
218
|
|
|
|
|
|
/* We temporarily set the interpreter context to the interpreter being |
219
|
|
|
|
|
|
* destroyed. It's in no condition to handle signals while it's being |
220
|
|
|
|
|
|
* taken apart. |
221
|
|
|
|
|
|
*/ |
222
|
|
|
|
|
|
S_block_most_signals(&origmask); |
223
|
|
|
|
|
|
#endif |
224
|
|
|
|
|
|
|
225
|
|
|
|
|
|
interp = thread->interp; |
226
|
|
|
|
|
|
if (interp) { |
227
|
|
|
|
|
|
dTHXa(interp); |
228
|
|
|
|
|
|
|
229
|
|
|
|
|
|
PERL_SET_CONTEXT(interp); |
230
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
231
|
|
|
|
|
|
|
232
|
|
|
|
|
|
SvREFCNT_dec(thread->params); |
233
|
|
|
|
|
|
thread->params = NULL; |
234
|
|
|
|
|
|
|
235
|
|
|
|
|
|
if (thread->err) { |
236
|
|
|
|
|
|
SvREFCNT_dec(thread->err); |
237
|
|
|
|
|
|
thread->err = Nullsv; |
238
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
240
|
|
|
|
|
|
perl_destruct(interp); |
241
|
|
|
|
|
|
perl_free(interp); |
242
|
|
|
|
|
|
thread->interp = NULL; |
243
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
245
|
|
|
|
|
|
PERL_SET_CONTEXT(aTHX); |
246
|
|
|
|
|
|
#ifndef WIN32 |
247
|
|
|
|
|
|
S_set_sigmask(&origmask); |
248
|
|
|
|
|
|
#endif |
249
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
252
|
|
|
|
|
|
/* Decrement the refcount of an ithread, and if it reaches zero, free it. |
253
|
|
|
|
|
|
* Must be called with the mutex held. |
254
|
|
|
|
|
|
* On return, mutex is released (or destroyed). |
255
|
|
|
|
|
|
*/ |
256
|
|
|
|
|
|
STATIC void |
257
|
|
|
|
|
|
S_ithread_free(pTHX_ ithread *thread) |
258
|
|
|
|
|
|
{ |
259
|
|
|
|
|
|
#ifdef WIN32 |
260
|
|
|
|
|
|
HANDLE handle; |
261
|
|
|
|
|
|
#endif |
262
|
|
|
|
|
|
dMY_POOL; |
263
|
|
|
|
|
|
|
264
|
|
|
|
|
|
if (! (thread->state & PERL_ITHR_NONVIABLE)) { |
265
|
|
|
|
|
|
assert(thread->count > 0); |
266
|
|
|
|
|
|
if (--thread->count > 0) { |
267
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
268
|
|
|
|
|
|
return; |
269
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
assert((thread->state & PERL_ITHR_FINISHED) && |
271
|
|
|
|
|
|
(thread->state & PERL_ITHR_UNCALLABLE)); |
272
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
274
|
|
|
|
|
|
|
275
|
|
|
|
|
|
/* Main thread (0) is immortal and should never get here */ |
276
|
|
|
|
|
|
assert(thread->tid != 0); |
277
|
|
|
|
|
|
|
278
|
|
|
|
|
|
/* Remove from circular list of threads */ |
279
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
280
|
|
|
|
|
|
assert(thread->prev && thread->next); |
281
|
|
|
|
|
|
thread->next->prev = thread->prev; |
282
|
|
|
|
|
|
thread->prev->next = thread->next; |
283
|
|
|
|
|
|
thread->next = NULL; |
284
|
|
|
|
|
|
thread->prev = NULL; |
285
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
286
|
|
|
|
|
|
|
287
|
|
|
|
|
|
/* Thread is now disowned */ |
288
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
289
|
|
|
|
|
|
S_ithread_clear(aTHX_ thread); |
290
|
|
|
|
|
|
|
291
|
|
|
|
|
|
#ifdef WIN32 |
292
|
|
|
|
|
|
handle = thread->handle; |
293
|
|
|
|
|
|
thread->handle = NULL; |
294
|
|
|
|
|
|
#endif |
295
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
296
|
|
|
|
|
|
MUTEX_DESTROY(&thread->mutex); |
297
|
|
|
|
|
|
|
298
|
|
|
|
|
|
#ifdef WIN32 |
299
|
|
|
|
|
|
if (handle) { |
300
|
|
|
|
|
|
CloseHandle(handle); |
301
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
#endif |
303
|
|
|
|
|
|
|
304
|
|
|
|
|
|
PerlMemShared_free(thread); |
305
|
|
|
|
|
|
|
306
|
|
|
|
|
|
/* total_threads >= 1 is used to veto cleanup by the main thread, |
307
|
|
|
|
|
|
* should it happen to exit while other threads still exist. |
308
|
|
|
|
|
|
* Decrement this as the very last thing in the thread's existence. |
309
|
|
|
|
|
|
* Otherwise, MY_POOL and global state such as PL_op_mutex may get |
310
|
|
|
|
|
|
* freed while we're still using it. |
311
|
|
|
|
|
|
*/ |
312
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
313
|
|
|
|
|
|
MY_POOL.total_threads--; |
314
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
315
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
318
|
|
|
|
|
|
static void |
319
|
|
|
|
|
|
S_ithread_count_inc(pTHX_ ithread *thread) |
320
|
|
|
|
|
|
{ |
321
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
322
|
|
|
|
|
|
thread->count++; |
323
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
324
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
327
|
|
|
|
|
|
/* Warn if exiting with any unjoined threads */ |
328
|
|
|
|
|
|
STATIC int |
329
|
|
|
|
|
|
S_exit_warning(pTHX) |
330
|
|
|
|
|
|
{ |
331
|
|
|
|
|
|
int veto_cleanup, warn; |
332
|
|
|
|
|
|
dMY_POOL; |
333
|
|
|
|
|
|
|
334
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
335
|
|
|
|
|
|
veto_cleanup = (MY_POOL.total_threads > 0); |
336
|
|
|
|
|
|
warn = (MY_POOL.running_threads || MY_POOL.joinable_threads); |
337
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
338
|
|
|
|
|
|
|
339
|
|
|
|
|
|
if (warn) { |
340
|
|
|
|
|
|
if (ckWARN_d(WARN_THREADS)) { |
341
|
|
|
|
|
|
Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" |
342
|
|
|
|
|
|
IVdf " running and unjoined\n\t%" |
343
|
|
|
|
|
|
IVdf " finished and unjoined\n\t%" |
344
|
|
|
|
|
|
IVdf " running and detached\n", |
345
|
|
|
|
|
|
MY_POOL.running_threads, |
346
|
|
|
|
|
|
MY_POOL.joinable_threads, |
347
|
|
|
|
|
|
MY_POOL.detached_threads); |
348
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
351
|
|
|
|
|
|
return (veto_cleanup); |
352
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
355
|
|
|
|
|
|
/* Called from perl_destruct() in each thread. If it's the main thread, |
356
|
|
|
|
|
|
* stop it from freeing everything if there are other threads still running. |
357
|
|
|
|
|
|
*/ |
358
|
|
|
|
|
|
int |
359
|
|
|
|
|
|
Perl_ithread_hook(pTHX) |
360
|
|
|
|
|
|
{ |
361
|
|
|
|
|
|
dMY_POOL; |
362
|
|
|
|
|
|
return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0); |
363
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
366
|
|
|
|
|
|
/* MAGIC (in mg.h sense) hooks */ |
367
|
|
|
|
|
|
|
368
|
|
|
|
|
|
int |
369
|
|
|
|
|
|
ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) |
370
|
|
|
|
|
|
{ |
371
|
|
|
|
|
|
ithread *thread = (ithread *)mg->mg_ptr; |
372
|
|
|
|
|
|
SvIV_set(sv, PTR2IV(thread)); |
373
|
|
|
|
|
|
SvIOK_on(sv); |
374
|
|
|
|
|
|
return (0); |
375
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
377
|
|
|
|
|
|
int |
378
|
|
|
|
|
|
ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) |
379
|
|
|
|
|
|
{ |
380
|
|
|
|
|
|
ithread *thread = (ithread *)mg->mg_ptr; |
381
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
382
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
383
|
|
|
|
|
|
S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
384
|
|
|
|
|
|
return (0); |
385
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
387
|
|
|
|
|
|
int |
388
|
|
|
|
|
|
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
389
|
|
|
|
|
|
{ |
390
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
391
|
|
|
|
|
|
S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr); |
392
|
|
|
|
|
|
return (0); |
393
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
395
|
|
|
|
|
|
MGVTBL ithread_vtbl = { |
396
|
|
|
|
|
|
ithread_mg_get, /* get */ |
397
|
|
|
|
|
|
0, /* set */ |
398
|
|
|
|
|
|
0, /* len */ |
399
|
|
|
|
|
|
0, /* clear */ |
400
|
|
|
|
|
|
ithread_mg_free, /* free */ |
401
|
|
|
|
|
|
0, /* copy */ |
402
|
|
|
|
|
|
ithread_mg_dup /* dup */ |
403
|
|
|
|
|
|
}; |
404
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
406
|
|
|
|
|
|
/* Provided default, minimum and rational stack sizes */ |
407
|
|
|
|
|
|
STATIC IV |
408
|
|
|
|
|
|
S_good_stack_size(pTHX_ IV stack_size) |
409
|
|
|
|
|
|
{ |
410
|
|
|
|
|
|
dMY_POOL; |
411
|
|
|
|
|
|
|
412
|
|
|
|
|
|
/* Use default stack size if no stack size specified */ |
413
|
|
|
|
|
|
if (! stack_size) { |
414
|
|
|
|
|
|
return (MY_POOL.default_stack_size); |
415
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
417
|
|
|
|
|
|
#ifdef PTHREAD_STACK_MIN |
418
|
|
|
|
|
|
/* Can't use less than minimum */ |
419
|
|
|
|
|
|
if (stack_size < PTHREAD_STACK_MIN) { |
420
|
|
|
|
|
|
if (ckWARN(WARN_THREADS)) { |
421
|
|
|
|
|
|
Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN); |
422
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
return (PTHREAD_STACK_MIN); |
424
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
#endif |
426
|
|
|
|
|
|
|
427
|
|
|
|
|
|
/* Round up to page size boundary */ |
428
|
|
|
|
|
|
if (MY_POOL.page_size <= 0) { |
429
|
|
|
|
|
|
#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) |
430
|
|
|
|
|
|
SETERRNO(0, SS_NORMAL); |
431
|
|
|
|
|
|
# ifdef _SC_PAGESIZE |
432
|
|
|
|
|
|
MY_POOL.page_size = sysconf(_SC_PAGESIZE); |
433
|
|
|
|
|
|
# else |
434
|
|
|
|
|
|
MY_POOL.page_size = sysconf(_SC_MMAP_PAGE_SIZE); |
435
|
|
|
|
|
|
# endif |
436
|
|
|
|
|
|
if ((long)MY_POOL.page_size < 0) { |
437
|
|
|
|
|
|
if (errno) { |
438
|
|
|
|
|
|
SV * const error = get_sv("@", 0); |
439
|
|
|
|
|
|
(void)SvUPGRADE(error, SVt_PV); |
440
|
|
|
|
|
|
Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error)); |
441
|
|
|
|
|
|
} else { |
442
|
|
|
|
|
|
Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown"); |
443
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
#else |
446
|
|
|
|
|
|
# ifdef HAS_GETPAGESIZE |
447
|
|
|
|
|
|
MY_POOL.page_size = getpagesize(); |
448
|
|
|
|
|
|
# else |
449
|
|
|
|
|
|
# if defined(I_SYS_PARAM) && defined(PAGESIZE) |
450
|
|
|
|
|
|
MY_POOL.page_size = PAGESIZE; |
451
|
|
|
|
|
|
# else |
452
|
|
|
|
|
|
MY_POOL.page_size = 8192; /* A conservative default */ |
453
|
|
|
|
|
|
# endif |
454
|
|
|
|
|
|
# endif |
455
|
|
|
|
|
|
if (MY_POOL.page_size <= 0) { |
456
|
|
|
|
|
|
Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size); |
457
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
#endif |
459
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size; |
461
|
|
|
|
|
|
|
462
|
|
|
|
|
|
return (stack_size); |
463
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
466
|
|
|
|
|
|
/* Starts executing the thread. |
467
|
|
|
|
|
|
* Passed as the C level function to run in the new thread. |
468
|
|
|
|
|
|
*/ |
469
|
|
|
|
|
|
#ifdef WIN32 |
470
|
|
|
|
|
|
STATIC THREAD_RET_TYPE |
471
|
|
|
|
|
|
S_ithread_run(LPVOID arg) |
472
|
|
|
|
|
|
#else |
473
|
|
|
|
|
|
STATIC void * |
474
|
|
|
|
|
|
S_ithread_run(void * arg) |
475
|
|
|
|
|
|
#endif |
476
|
|
|
|
|
|
{ |
477
|
|
|
|
|
|
ithread *thread = (ithread *)arg; |
478
|
|
|
|
|
|
int jmp_rc = 0; |
479
|
|
|
|
|
|
I32 oldscope; |
480
|
|
|
|
|
|
int exit_app = 0; /* Thread terminated using 'exit' */ |
481
|
|
|
|
|
|
int exit_code = 0; |
482
|
|
|
|
|
|
int died = 0; /* Thread terminated abnormally */ |
483
|
|
|
|
|
|
|
484
|
|
|
|
|
|
dJMPENV; |
485
|
|
|
|
|
|
|
486
|
|
|
|
|
|
dTHXa(thread->interp); |
487
|
|
|
|
|
|
|
488
|
|
|
|
|
|
dMY_POOL; |
489
|
|
|
|
|
|
|
490
|
|
|
|
|
|
/* Blocked until ->create() call finishes */ |
491
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
492
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
493
|
|
|
|
|
|
|
494
|
|
|
|
|
|
PERL_SET_CONTEXT(thread->interp); |
495
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
496
|
|
|
|
|
|
|
497
|
|
|
|
|
|
#ifndef WIN32 |
498
|
|
|
|
|
|
/* Thread starts with most signals blocked - restore the signal mask from |
499
|
|
|
|
|
|
* the ithread struct. |
500
|
|
|
|
|
|
*/ |
501
|
|
|
|
|
|
S_set_sigmask(&thread->initial_sigmask); |
502
|
|
|
|
|
|
#endif |
503
|
|
|
|
|
|
|
504
|
|
|
|
|
|
PL_perl_destruct_level = 2; |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
{ |
507
|
|
|
|
|
|
AV *params = thread->params; |
508
|
|
|
|
|
|
int len = (int)av_len(params)+1; |
509
|
|
|
|
|
|
int ii; |
510
|
|
|
|
|
|
|
511
|
|
|
|
|
|
dSP; |
512
|
|
|
|
|
|
ENTER; |
513
|
|
|
|
|
|
SAVETMPS; |
514
|
|
|
|
|
|
|
515
|
|
|
|
|
|
/* Put args on the stack */ |
516
|
|
|
|
|
|
PUSHMARK(SP); |
517
|
|
|
|
|
|
for (ii=0; ii < len; ii++) { |
518
|
|
|
|
|
|
XPUSHs(av_shift(params)); |
519
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
PUTBACK; |
521
|
|
|
|
|
|
|
522
|
|
|
|
|
|
oldscope = PL_scopestack_ix; |
523
|
|
|
|
|
|
JMPENV_PUSH(jmp_rc); |
524
|
|
|
|
|
|
if (jmp_rc == 0) { |
525
|
|
|
|
|
|
/* Run the specified function */ |
526
|
|
|
|
|
|
len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); |
527
|
|
|
|
|
|
} else if (jmp_rc == 2) { |
528
|
|
|
|
|
|
/* Thread exited */ |
529
|
|
|
|
|
|
exit_app = 1; |
530
|
|
|
|
|
|
exit_code = STATUS_CURRENT; |
531
|
|
|
|
|
|
while (PL_scopestack_ix > oldscope) { |
532
|
|
|
|
|
|
LEAVE; |
533
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
JMPENV_POP; |
536
|
|
|
|
|
|
|
537
|
|
|
|
|
|
#ifndef WIN32 |
538
|
|
|
|
|
|
/* The interpreter is finished, so this thread can stop receiving |
539
|
|
|
|
|
|
* signals. This way, our signal handler doesn't get called in the |
540
|
|
|
|
|
|
* middle of our parent thread calling perl_destruct()... |
541
|
|
|
|
|
|
*/ |
542
|
|
|
|
|
|
S_block_most_signals(NULL); |
543
|
|
|
|
|
|
#endif |
544
|
|
|
|
|
|
|
545
|
|
|
|
|
|
/* Remove args from stack and put back in params array */ |
546
|
|
|
|
|
|
SPAGAIN; |
547
|
|
|
|
|
|
for (ii=len-1; ii >= 0; ii--) { |
548
|
|
|
|
|
|
SV *sv = POPs; |
549
|
|
|
|
|
|
if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) { |
550
|
|
|
|
|
|
av_store(params, ii, SvREFCNT_inc(sv)); |
551
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
554
|
|
|
|
|
|
FREETMPS; |
555
|
|
|
|
|
|
LEAVE; |
556
|
|
|
|
|
|
|
557
|
|
|
|
|
|
/* Check for abnormal termination */ |
558
|
|
|
|
|
|
if (SvTRUE(ERRSV)) { |
559
|
|
|
|
|
|
died = PERL_ITHR_DIED; |
560
|
|
|
|
|
|
thread->err = newSVsv(ERRSV); |
561
|
|
|
|
|
|
/* If ERRSV is an object, remember the classname and then |
562
|
|
|
|
|
|
* rebless into 'main' so it will survive 'cloning' |
563
|
|
|
|
|
|
*/ |
564
|
|
|
|
|
|
if (sv_isobject(thread->err)) { |
565
|
|
|
|
|
|
thread->err_class = HvNAME(SvSTASH(SvRV(thread->err))); |
566
|
|
|
|
|
|
sv_bless(thread->err, gv_stashpv("main", 0)); |
567
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
569
|
|
|
|
|
|
if (ckWARN_d(WARN_THREADS)) { |
570
|
|
|
|
|
|
oldscope = PL_scopestack_ix; |
571
|
|
|
|
|
|
JMPENV_PUSH(jmp_rc); |
572
|
|
|
|
|
|
if (jmp_rc == 0) { |
573
|
|
|
|
|
|
/* Warn that thread died */ |
574
|
|
|
|
|
|
Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); |
575
|
|
|
|
|
|
} else if (jmp_rc == 2) { |
576
|
|
|
|
|
|
/* Warn handler exited */ |
577
|
|
|
|
|
|
exit_app = 1; |
578
|
|
|
|
|
|
exit_code = STATUS_CURRENT; |
579
|
|
|
|
|
|
while (PL_scopestack_ix > oldscope) { |
580
|
|
|
|
|
|
LEAVE; |
581
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
JMPENV_POP; |
584
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
587
|
|
|
|
|
|
/* Release function ref */ |
588
|
|
|
|
|
|
SvREFCNT_dec(thread->init_function); |
589
|
|
|
|
|
|
thread->init_function = Nullsv; |
590
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
592
|
|
|
|
|
|
PerlIO_flush((PerlIO *)NULL); |
593
|
|
|
|
|
|
|
594
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
595
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
596
|
|
|
|
|
|
/* Mark as finished */ |
597
|
|
|
|
|
|
thread->state |= (PERL_ITHR_FINISHED | died); |
598
|
|
|
|
|
|
/* Clear exit flag if required */ |
599
|
|
|
|
|
|
if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) { |
600
|
|
|
|
|
|
exit_app = 0; |
601
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
603
|
|
|
|
|
|
/* Adjust thread status counts */ |
604
|
|
|
|
|
|
if (thread->state & PERL_ITHR_DETACHED) { |
605
|
|
|
|
|
|
MY_POOL.detached_threads--; |
606
|
|
|
|
|
|
} else { |
607
|
|
|
|
|
|
MY_POOL.running_threads--; |
608
|
|
|
|
|
|
MY_POOL.joinable_threads++; |
609
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
611
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
612
|
|
|
|
|
|
|
613
|
|
|
|
|
|
/* Exit application if required */ |
614
|
|
|
|
|
|
if (exit_app) { |
615
|
|
|
|
|
|
oldscope = PL_scopestack_ix; |
616
|
|
|
|
|
|
JMPENV_PUSH(jmp_rc); |
617
|
|
|
|
|
|
if (jmp_rc == 0) { |
618
|
|
|
|
|
|
/* Warn if there are unjoined threads */ |
619
|
|
|
|
|
|
S_exit_warning(aTHX); |
620
|
|
|
|
|
|
} else if (jmp_rc == 2) { |
621
|
|
|
|
|
|
/* Warn handler exited */ |
622
|
|
|
|
|
|
exit_code = STATUS_CURRENT; |
623
|
|
|
|
|
|
while (PL_scopestack_ix > oldscope) { |
624
|
|
|
|
|
|
LEAVE; |
625
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
JMPENV_POP; |
628
|
|
|
|
|
|
|
629
|
|
|
|
|
|
my_exit(exit_code); |
630
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
632
|
|
|
|
|
|
/* At this point, the interpreter may have been freed, so call |
633
|
|
|
|
|
|
* free in the the context of of the 'main' interpreter which |
634
|
|
|
|
|
|
* can't have been freed due to the veto_cleanup mechanism. |
635
|
|
|
|
|
|
*/ |
636
|
|
|
|
|
|
aTHX = MY_POOL.main_thread.interp; |
637
|
|
|
|
|
|
|
638
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
639
|
|
|
|
|
|
S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
640
|
|
|
|
|
|
|
641
|
|
|
|
|
|
#ifdef WIN32 |
642
|
|
|
|
|
|
return ((DWORD)0); |
643
|
|
|
|
|
|
#else |
644
|
|
|
|
|
|
return (0); |
645
|
|
|
|
|
|
#endif |
646
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
649
|
|
|
|
|
|
/* Type conversion helper functions */ |
650
|
|
|
|
|
|
|
651
|
|
|
|
|
|
STATIC SV * |
652
|
|
|
|
|
|
S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) |
653
|
|
|
|
|
|
{ |
654
|
|
|
|
|
|
SV *sv; |
655
|
|
|
|
|
|
MAGIC *mg; |
656
|
|
|
|
|
|
|
657
|
|
|
|
|
|
if (inc) |
658
|
|
|
|
|
|
S_ithread_count_inc(aTHX_ thread); |
659
|
|
|
|
|
|
|
660
|
|
|
|
|
|
if (! obj) { |
661
|
|
|
|
|
|
obj = newSV(0); |
662
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
664
|
|
|
|
|
|
sv = newSVrv(obj, classname); |
665
|
|
|
|
|
|
sv_setiv(sv, PTR2IV(thread)); |
666
|
|
|
|
|
|
mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0); |
667
|
|
|
|
|
|
mg->mg_flags |= MGf_DUP; |
668
|
|
|
|
|
|
SvREADONLY_on(sv); |
669
|
|
|
|
|
|
|
670
|
|
|
|
|
|
return (obj); |
671
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
673
|
|
|
|
|
|
STATIC ithread * |
674
|
|
|
|
|
|
S_SV_to_ithread(pTHX_ SV *sv) |
675
|
|
|
|
|
|
{ |
676
|
|
|
|
|
|
/* Argument is a thread */ |
677
|
|
|
|
|
|
if (SvROK(sv)) { |
678
|
|
|
|
|
|
return (INT2PTR(ithread *, SvIV(SvRV(sv)))); |
679
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
/* Argument is classname, therefore return current thread */ |
681
|
|
|
|
|
|
return (S_ithread_get(aTHX)); |
682
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
685
|
|
|
|
|
|
/* threads->create() |
686
|
|
|
|
|
|
* Called in context of parent thread. |
687
|
|
|
|
|
|
* Called with MY_POOL.create_destruct_mutex locked. (Unlocked on error.) |
688
|
|
|
|
|
|
*/ |
689
|
|
|
|
|
|
STATIC ithread * |
690
|
|
|
|
|
|
S_ithread_create( |
691
|
|
|
|
|
|
PerlInterpreter *parent_perl, |
692
|
|
|
|
|
|
SV *init_function, |
693
|
|
|
|
|
|
IV stack_size, |
694
|
|
|
|
|
|
int gimme, |
695
|
|
|
|
|
|
int exit_opt, |
696
|
|
|
|
|
|
int params_start, |
697
|
|
|
|
|
|
int num_params) |
698
|
|
|
|
|
|
{ |
699
|
|
|
|
|
|
dTHXa(parent_perl); |
700
|
|
|
|
|
|
ithread *thread; |
701
|
|
|
|
|
|
ithread *current_thread = S_ithread_get(aTHX); |
702
|
|
|
|
|
|
AV *params; |
703
|
|
|
|
|
|
SV **array; |
704
|
|
|
|
|
|
|
705
|
|
|
|
|
|
#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 |
706
|
|
|
|
|
|
SV **tmps_tmp = PL_tmps_stack; |
707
|
|
|
|
|
|
IV tmps_ix = PL_tmps_ix; |
708
|
|
|
|
|
|
#endif |
709
|
|
|
|
|
|
#ifndef WIN32 |
710
|
|
|
|
|
|
int rc_stack_size = 0; |
711
|
|
|
|
|
|
int rc_thread_create = 0; |
712
|
|
|
|
|
|
#endif |
713
|
|
|
|
|
|
dMY_POOL; |
714
|
|
|
|
|
|
|
715
|
|
|
|
|
|
/* Allocate thread structure in context of the main thread's interpreter */ |
716
|
|
|
|
|
|
{ |
717
|
|
|
|
|
|
PERL_SET_CONTEXT(MY_POOL.main_thread.interp); |
718
|
|
|
|
|
|
thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); |
719
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
PERL_SET_CONTEXT(aTHX); |
721
|
|
|
|
|
|
if (!thread) { |
722
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
723
|
|
|
|
|
|
PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); |
724
|
|
|
|
|
|
my_exit(1); |
725
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
Zero(thread, 1, ithread); |
727
|
|
|
|
|
|
|
728
|
|
|
|
|
|
/* Add to threads list */ |
729
|
|
|
|
|
|
thread->next = &MY_POOL.main_thread; |
730
|
|
|
|
|
|
thread->prev = MY_POOL.main_thread.prev; |
731
|
|
|
|
|
|
MY_POOL.main_thread.prev = thread; |
732
|
|
|
|
|
|
thread->prev->next = thread; |
733
|
|
|
|
|
|
MY_POOL.total_threads++; |
734
|
|
|
|
|
|
|
735
|
|
|
|
|
|
/* 1 ref to be held by the local var 'thread' in S_ithread_run(). |
736
|
|
|
|
|
|
* 1 ref to be held by the threads object that we assume we will |
737
|
|
|
|
|
|
* be embedded in upon our return. |
738
|
|
|
|
|
|
* 1 ref to be the responsibility of join/detach, so we don't get |
739
|
|
|
|
|
|
* freed until join/detach, even if no thread objects remain. |
740
|
|
|
|
|
|
* This allows the following to work: |
741
|
|
|
|
|
|
* { threads->create(sub{...}); } threads->object(1)->join; |
742
|
|
|
|
|
|
*/ |
743
|
|
|
|
|
|
thread->count = 3; |
744
|
|
|
|
|
|
|
745
|
|
|
|
|
|
/* Block new thread until ->create() call finishes */ |
746
|
|
|
|
|
|
MUTEX_INIT(&thread->mutex); |
747
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
748
|
|
|
|
|
|
|
749
|
|
|
|
|
|
thread->tid = MY_POOL.tid_counter++; |
750
|
|
|
|
|
|
thread->stack_size = S_good_stack_size(aTHX_ stack_size); |
751
|
|
|
|
|
|
thread->gimme = gimme; |
752
|
|
|
|
|
|
thread->state = exit_opt; |
753
|
|
|
|
|
|
|
754
|
|
|
|
|
|
/* "Clone" our interpreter into the thread's interpreter. |
755
|
|
|
|
|
|
* This gives thread access to "static data" and code. |
756
|
|
|
|
|
|
*/ |
757
|
|
|
|
|
|
PerlIO_flush((PerlIO *)NULL); |
758
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
759
|
|
|
|
|
|
|
760
|
|
|
|
|
|
SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */ |
761
|
|
|
|
|
|
PL_srand_called = FALSE; /* Set it to false so we can detect if it gets |
762
|
|
|
|
|
|
set during the clone */ |
763
|
|
|
|
|
|
|
764
|
|
|
|
|
|
#ifndef WIN32 |
765
|
|
|
|
|
|
/* perl_clone() will leave us the new interpreter's context. This poses |
766
|
|
|
|
|
|
* two problems for our signal handler. First, it sets the new context |
767
|
|
|
|
|
|
* before the new interpreter struct is fully initialized, so our signal |
768
|
|
|
|
|
|
* handler might find bogus data in the interpreter struct it gets. |
769
|
|
|
|
|
|
* Second, even if the interpreter is initialized before a signal comes in, |
770
|
|
|
|
|
|
* we would like to avoid that interpreter receiving notifications for |
771
|
|
|
|
|
|
* signals (especially when they ought to be for the one running in this |
772
|
|
|
|
|
|
* thread), until it is running in its own thread. Another problem is that |
773
|
|
|
|
|
|
* the new thread will not have set the context until some time after it |
774
|
|
|
|
|
|
* has started, so it won't be safe for our signal handler to run until |
775
|
|
|
|
|
|
* that time. |
776
|
|
|
|
|
|
* |
777
|
|
|
|
|
|
* So we block most signals here, so the new thread will inherit the signal |
778
|
|
|
|
|
|
* mask, and unblock them right after the thread creation. The original |
779
|
|
|
|
|
|
* mask is saved in the thread struct so that the new thread can restore |
780
|
|
|
|
|
|
* the original mask. |
781
|
|
|
|
|
|
*/ |
782
|
|
|
|
|
|
S_block_most_signals(&thread->initial_sigmask); |
783
|
|
|
|
|
|
#endif |
784
|
|
|
|
|
|
|
785
|
|
|
|
|
|
#ifdef WIN32 |
786
|
|
|
|
|
|
thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
787
|
|
|
|
|
|
#else |
788
|
|
|
|
|
|
thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
789
|
|
|
|
|
|
#endif |
790
|
|
|
|
|
|
|
791
|
|
|
|
|
|
/* perl_clone() leaves us in new interpreter's context. As it is tricky |
792
|
|
|
|
|
|
* to spot an implicit aTHX, create a new scope with aTHX matching the |
793
|
|
|
|
|
|
* context for the duration of our work for new interpreter. |
794
|
|
|
|
|
|
*/ |
795
|
|
|
|
|
|
{ |
796
|
|
|
|
|
|
#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1) |
797
|
|
|
|
|
|
CLONE_PARAMS *clone_param = Perl_clone_params_new(aTHX, thread->interp); |
798
|
|
|
|
|
|
#else |
799
|
|
|
|
|
|
CLONE_PARAMS clone_param_s; |
800
|
|
|
|
|
|
CLONE_PARAMS *clone_param = &clone_param_s; |
801
|
|
|
|
|
|
#endif |
802
|
|
|
|
|
|
dTHXa(thread->interp); |
803
|
|
|
|
|
|
|
804
|
|
|
|
|
|
MY_CXT_CLONE; |
805
|
|
|
|
|
|
|
806
|
|
|
|
|
|
#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) |
807
|
|
|
|
|
|
clone_param->flags = 0; |
808
|
|
|
|
|
|
#endif |
809
|
|
|
|
|
|
|
810
|
|
|
|
|
|
/* Here we remove END blocks since they should only run in the thread |
811
|
|
|
|
|
|
* they are created |
812
|
|
|
|
|
|
*/ |
813
|
|
|
|
|
|
SvREFCNT_dec(PL_endav); |
814
|
|
|
|
|
|
PL_endav = NULL; |
815
|
|
|
|
|
|
|
816
|
|
|
|
|
|
if (SvPOK(init_function)) { |
817
|
|
|
|
|
|
thread->init_function = newSV(0); |
818
|
|
|
|
|
|
sv_copypv(thread->init_function, init_function); |
819
|
|
|
|
|
|
} else { |
820
|
|
|
|
|
|
thread->init_function = sv_dup_inc(init_function, clone_param); |
821
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
823
|
|
|
|
|
|
thread->params = params = newAV(); |
824
|
|
|
|
|
|
av_extend(params, num_params - 1); |
825
|
|
|
|
|
|
AvFILLp(params) = num_params - 1; |
826
|
|
|
|
|
|
array = AvARRAY(params); |
827
|
|
|
|
|
|
|
828
|
|
|
|
|
|
/* params_start is an offset onto the Perl stack. This can be |
829
|
|
|
|
|
|
reallocated (and hence move) as a side effect of calls to |
830
|
|
|
|
|
|
perl_clone() and sv_dup_inc(). Hence copy the parameters |
831
|
|
|
|
|
|
somewhere under our control first, before duplicating. */ |
832
|
|
|
|
|
|
#if (PERL_VERSION > 8) |
833
|
|
|
|
|
|
Copy(parent_perl->Istack_base + params_start, array, num_params, SV *); |
834
|
|
|
|
|
|
#else |
835
|
|
|
|
|
|
Copy(parent_perl->Tstack_base + params_start, array, num_params, SV *); |
836
|
|
|
|
|
|
#endif |
837
|
|
|
|
|
|
while (num_params--) { |
838
|
|
|
|
|
|
*array = sv_dup_inc(*array, clone_param); |
839
|
|
|
|
|
|
++array; |
840
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1) |
842
|
|
|
|
|
|
Perl_clone_params_del(clone_param); |
843
|
|
|
|
|
|
#endif |
844
|
|
|
|
|
|
|
845
|
|
|
|
|
|
#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 |
846
|
|
|
|
|
|
/* The code below checks that anything living on the tmps stack and |
847
|
|
|
|
|
|
* has been cloned (so it lives in the ptr_table) has a refcount |
848
|
|
|
|
|
|
* higher than 0. |
849
|
|
|
|
|
|
* |
850
|
|
|
|
|
|
* If the refcount is 0 it means that a something on the stack/context |
851
|
|
|
|
|
|
* was holding a reference to it and since we init_stacks() in |
852
|
|
|
|
|
|
* perl_clone that won't get cleaned and we will get a leaked scalar. |
853
|
|
|
|
|
|
* The reason it was cloned was that it lived on the @_ stack. |
854
|
|
|
|
|
|
* |
855
|
|
|
|
|
|
* Example of this can be found in bugreport 15837 where calls in the |
856
|
|
|
|
|
|
* parameter list end up as a temp. |
857
|
|
|
|
|
|
* |
858
|
|
|
|
|
|
* As of 5.8.8 this is done in perl_clone. |
859
|
|
|
|
|
|
*/ |
860
|
|
|
|
|
|
while (tmps_ix > 0) { |
861
|
|
|
|
|
|
SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); |
862
|
|
|
|
|
|
tmps_ix--; |
863
|
|
|
|
|
|
if (sv && SvREFCNT(sv) == 0) { |
864
|
|
|
|
|
|
SvREFCNT_inc_void(sv); |
865
|
|
|
|
|
|
SvREFCNT_dec(sv); |
866
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
#endif |
869
|
|
|
|
|
|
|
870
|
|
|
|
|
|
SvTEMP_off(thread->init_function); |
871
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
872
|
|
|
|
|
|
PL_ptr_table = NULL; |
873
|
|
|
|
|
|
PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
874
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
S_ithread_set(aTHX_ current_thread); |
876
|
|
|
|
|
|
PERL_SET_CONTEXT(aTHX); |
877
|
|
|
|
|
|
|
878
|
|
|
|
|
|
/* Create/start the thread */ |
879
|
|
|
|
|
|
#ifdef WIN32 |
880
|
|
|
|
|
|
thread->handle = CreateThread(NULL, |
881
|
|
|
|
|
|
(DWORD)thread->stack_size, |
882
|
|
|
|
|
|
S_ithread_run, |
883
|
|
|
|
|
|
(LPVOID)thread, |
884
|
|
|
|
|
|
STACK_SIZE_PARAM_IS_A_RESERVATION, |
885
|
|
|
|
|
|
&thread->thr); |
886
|
|
|
|
|
|
#else |
887
|
|
|
|
|
|
{ |
888
|
|
|
|
|
|
STATIC pthread_attr_t attr; |
889
|
|
|
|
|
|
STATIC int attr_inited = 0; |
890
|
|
|
|
|
|
STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE; |
891
|
|
|
|
|
|
if (! attr_inited) { |
892
|
|
|
|
|
|
pthread_attr_init(&attr); |
893
|
|
|
|
|
|
attr_inited = 1; |
894
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
896
|
|
|
|
|
|
# ifdef PTHREAD_ATTR_SETDETACHSTATE |
897
|
|
|
|
|
|
/* Threads start out joinable */ |
898
|
|
|
|
|
|
PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); |
899
|
|
|
|
|
|
# endif |
900
|
|
|
|
|
|
|
901
|
|
|
|
|
|
# ifdef _POSIX_THREAD_ATTR_STACKSIZE |
902
|
|
|
|
|
|
/* Set thread's stack size */ |
903
|
|
|
|
|
|
if (thread->stack_size > 0) { |
904
|
|
|
|
|
|
rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); |
905
|
|
|
|
|
|
} |
906
|
|
|
|
|
|
# endif |
907
|
|
|
|
|
|
|
908
|
|
|
|
|
|
/* Create the thread */ |
909
|
|
|
|
|
|
if (! rc_stack_size) { |
910
|
|
|
|
|
|
# ifdef OLD_PTHREADS_API |
911
|
|
|
|
|
|
rc_thread_create = pthread_create(&thread->thr, |
912
|
|
|
|
|
|
attr, |
913
|
|
|
|
|
|
S_ithread_run, |
914
|
|
|
|
|
|
(void *)thread); |
915
|
|
|
|
|
|
# else |
916
|
|
|
|
|
|
# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) |
917
|
|
|
|
|
|
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); |
918
|
|
|
|
|
|
# endif |
919
|
|
|
|
|
|
rc_thread_create = pthread_create(&thread->thr, |
920
|
|
|
|
|
|
&attr, |
921
|
|
|
|
|
|
S_ithread_run, |
922
|
|
|
|
|
|
(void *)thread); |
923
|
|
|
|
|
|
# endif |
924
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
926
|
|
|
|
|
|
#ifndef WIN32 |
927
|
|
|
|
|
|
/* Now it's safe to accept signals, since we're in our own interpreter's |
928
|
|
|
|
|
|
* context and we have created the thread. |
929
|
|
|
|
|
|
*/ |
930
|
|
|
|
|
|
S_set_sigmask(&thread->initial_sigmask); |
931
|
|
|
|
|
|
#endif |
932
|
|
|
|
|
|
|
933
|
|
|
|
|
|
# ifdef _POSIX_THREAD_ATTR_STACKSIZE |
934
|
|
|
|
|
|
/* Try to get thread's actual stack size */ |
935
|
|
|
|
|
|
{ |
936
|
|
|
|
|
|
size_t stacksize; |
937
|
|
|
|
|
|
#ifdef HPUX1020 |
938
|
|
|
|
|
|
stacksize = pthread_attr_getstacksize(attr); |
939
|
|
|
|
|
|
#else |
940
|
|
|
|
|
|
if (! pthread_attr_getstacksize(&attr, &stacksize)) |
941
|
|
|
|
|
|
#endif |
942
|
|
|
|
|
|
if (stacksize > 0) { |
943
|
|
|
|
|
|
thread->stack_size = (IV)stacksize; |
944
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
} |
946
|
|
|
|
|
|
# endif |
947
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
#endif |
949
|
|
|
|
|
|
|
950
|
|
|
|
|
|
/* Check for errors */ |
951
|
|
|
|
|
|
#ifdef WIN32 |
952
|
|
|
|
|
|
if (thread->handle == NULL) { |
953
|
|
|
|
|
|
#else |
954
|
|
|
|
|
|
if (rc_stack_size || rc_thread_create) { |
955
|
|
|
|
|
|
#endif |
956
|
|
|
|
|
|
/* Must unlock mutex for destruct call */ |
957
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
958
|
|
|
|
|
|
thread->state |= PERL_ITHR_NONVIABLE; |
959
|
|
|
|
|
|
S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
960
|
|
|
|
|
|
#ifndef WIN32 |
961
|
|
|
|
|
|
if (ckWARN_d(WARN_THREADS)) { |
962
|
|
|
|
|
|
if (rc_stack_size) { |
963
|
|
|
|
|
|
Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); |
964
|
|
|
|
|
|
} else { |
965
|
|
|
|
|
|
Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); |
966
|
|
|
|
|
|
} |
967
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
#endif |
969
|
|
|
|
|
|
return (NULL); |
970
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
972
|
|
|
|
|
|
MY_POOL.running_threads++; |
973
|
|
|
|
|
|
return (thread); |
974
|
|
|
|
|
|
} |
975
|
|
|
|
|
|
|
976
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
977
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
979
|
|
|
|
|
|
#line 980 "threads.c" |
980
|
|
|
|
|
|
#ifndef PERL_UNUSED_VAR |
981
|
|
|
|
|
|
# define PERL_UNUSED_VAR(var) if (0) var = var |
982
|
|
|
|
|
|
#endif |
983
|
|
|
|
|
|
|
984
|
|
|
|
|
|
#ifndef dVAR |
985
|
|
|
|
|
|
# define dVAR dNOOP |
986
|
|
|
|
|
|
#endif |
987
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
989
|
|
|
|
|
|
/* This stuff is not part of the API! You have been warned. */ |
990
|
|
|
|
|
|
#ifndef PERL_VERSION_DECIMAL |
991
|
|
|
|
|
|
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) |
992
|
|
|
|
|
|
#endif |
993
|
|
|
|
|
|
#ifndef PERL_DECIMAL_VERSION |
994
|
|
|
|
|
|
# define PERL_DECIMAL_VERSION \ |
995
|
|
|
|
|
|
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) |
996
|
|
|
|
|
|
#endif |
997
|
|
|
|
|
|
#ifndef PERL_VERSION_GE |
998
|
|
|
|
|
|
# define PERL_VERSION_GE(r,v,s) \ |
999
|
|
|
|
|
|
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) |
1000
|
|
|
|
|
|
#endif |
1001
|
|
|
|
|
|
#ifndef PERL_VERSION_LE |
1002
|
|
|
|
|
|
# define PERL_VERSION_LE(r,v,s) \ |
1003
|
|
|
|
|
|
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) |
1004
|
|
|
|
|
|
#endif |
1005
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
/* XS_INTERNAL is the explicit static-linkage variant of the default |
1007
|
|
|
|
|
|
* XS macro. |
1008
|
|
|
|
|
|
* |
1009
|
|
|
|
|
|
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include |
1010
|
|
|
|
|
|
* "STATIC", ie. it exports XSUB symbols. You probably don't want that |
1011
|
|
|
|
|
|
* for anything but the BOOT XSUB. |
1012
|
|
|
|
|
|
* |
1013
|
|
|
|
|
|
* See XSUB.h in core! |
1014
|
|
|
|
|
|
*/ |
1015
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
/* TODO: This might be compatible further back than 5.10.0. */ |
1018
|
|
|
|
|
|
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) |
1019
|
|
|
|
|
|
# undef XS_EXTERNAL |
1020
|
|
|
|
|
|
# undef XS_INTERNAL |
1021
|
|
|
|
|
|
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) |
1022
|
|
|
|
|
|
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) |
1023
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC XSPROTO(name) |
1024
|
|
|
|
|
|
# endif |
1025
|
|
|
|
|
|
# if defined(__SYMBIAN32__) |
1026
|
|
|
|
|
|
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) |
1027
|
|
|
|
|
|
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) |
1028
|
|
|
|
|
|
# endif |
1029
|
|
|
|
|
|
# ifndef XS_EXTERNAL |
1030
|
|
|
|
|
|
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) |
1031
|
|
|
|
|
|
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) |
1032
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) |
1033
|
|
|
|
|
|
# else |
1034
|
|
|
|
|
|
# ifdef __cplusplus |
1035
|
|
|
|
|
|
# define XS_EXTERNAL(name) extern "C" XSPROTO(name) |
1036
|
|
|
|
|
|
# define XS_INTERNAL(name) static XSPROTO(name) |
1037
|
|
|
|
|
|
# else |
1038
|
|
|
|
|
|
# define XS_EXTERNAL(name) XSPROTO(name) |
1039
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC XSPROTO(name) |
1040
|
|
|
|
|
|
# endif |
1041
|
|
|
|
|
|
# endif |
1042
|
|
|
|
|
|
# endif |
1043
|
|
|
|
|
|
#endif |
1044
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
/* perl >= 5.10.0 && perl <= 5.15.1 */ |
1046
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
/* The XS_EXTERNAL macro is used for functions that must not be static |
1049
|
|
|
|
|
|
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL |
1050
|
|
|
|
|
|
* macro defined, the best we can do is assume XS is the same. |
1051
|
|
|
|
|
|
* Dito for XS_INTERNAL. |
1052
|
|
|
|
|
|
*/ |
1053
|
|
|
|
|
|
#ifndef XS_EXTERNAL |
1054
|
|
|
|
|
|
# define XS_EXTERNAL(name) XS(name) |
1055
|
|
|
|
|
|
#endif |
1056
|
|
|
|
|
|
#ifndef XS_INTERNAL |
1057
|
|
|
|
|
|
# define XS_INTERNAL(name) XS(name) |
1058
|
|
|
|
|
|
#endif |
1059
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
/* Now, finally, after all this mess, we want an ExtUtils::ParseXS |
1061
|
|
|
|
|
|
* internal macro that we're free to redefine for varying linkage due |
1062
|
|
|
|
|
|
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use |
1063
|
|
|
|
|
|
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! |
1064
|
|
|
|
|
|
*/ |
1065
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
#undef XS_EUPXS |
1067
|
|
|
|
|
|
#if defined(PERL_EUPXS_ALWAYS_EXPORT) |
1068
|
|
|
|
|
|
# define XS_EUPXS(name) XS_EXTERNAL(name) |
1069
|
|
|
|
|
|
#else |
1070
|
|
|
|
|
|
/* default to internal */ |
1071
|
|
|
|
|
|
# define XS_EUPXS(name) XS_INTERNAL(name) |
1072
|
|
|
|
|
|
#endif |
1073
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE |
1075
|
|
|
|
|
|
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) |
1076
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
/* prototype to pass -Wmissing-prototypes */ |
1078
|
|
|
|
|
|
STATIC void |
1079
|
|
|
|
|
|
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); |
1080
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
STATIC void |
1082
|
|
|
|
|
|
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) |
1083
|
|
|
|
|
|
{ |
1084
|
|
|
|
|
|
const GV *const gv = CvGV(cv); |
1085
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
PERL_ARGS_ASSERT_CROAK_XS_USAGE; |
1087
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
if (gv) { |
1089
|
|
|
|
|
|
const char *const gvname = GvNAME(gv); |
1090
|
|
|
|
|
|
const HV *const stash = GvSTASH(gv); |
1091
|
|
|
|
|
|
const char *const hvname = stash ? HvNAME(stash) : NULL; |
1092
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
if (hvname) |
1094
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); |
1095
|
|
|
|
|
|
else |
1096
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); |
1097
|
|
|
|
|
|
} else { |
1098
|
|
|
|
|
|
/* Pants. I don't think that it should be possible to get here. */ |
1099
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); |
1100
|
|
|
|
|
|
} |
1101
|
|
|
|
|
|
} |
1102
|
|
|
|
|
|
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE |
1103
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_CONTEXT |
1105
|
|
|
|
|
|
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) |
1106
|
|
|
|
|
|
#else |
1107
|
|
|
|
|
|
#define croak_xs_usage S_croak_xs_usage |
1108
|
|
|
|
|
|
#endif |
1109
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
#endif |
1111
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
/* NOTE: the prototype of newXSproto() is different in versions of perls, |
1113
|
|
|
|
|
|
* so we define a portable version of newXSproto() |
1114
|
|
|
|
|
|
*/ |
1115
|
|
|
|
|
|
#ifdef newXS_flags |
1116
|
|
|
|
|
|
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) |
1117
|
|
|
|
|
|
#else |
1118
|
|
|
|
|
|
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) |
1119
|
|
|
|
|
|
#endif /* !defined(newXS_flags) */ |
1120
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
#line 1122 "threads.c" |
1122
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1123
|
|
|
|
|
|
#define XSubPPtmpAAAA 1 |
1124
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
XS_EUPXS(XS_threads_create); /* prototype to pass -Wmissing-prototypes */ |
1127
|
|
|
|
|
|
XS_EUPXS(XS_threads_create) |
1128
|
|
|
|
|
|
{ |
1129
|
|
|
|
|
|
dVAR; dXSARGS; |
1130
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1131
|
|
|
|
|
|
{ |
1132
|
|
|
|
|
|
#line 978 "threads.xs" |
1133
|
|
|
|
|
|
char *classname; |
1134
|
|
|
|
|
|
ithread *thread; |
1135
|
|
|
|
|
|
SV *function_to_call; |
1136
|
|
|
|
|
|
HV *specs; |
1137
|
|
|
|
|
|
IV stack_size; |
1138
|
|
|
|
|
|
int context; |
1139
|
|
|
|
|
|
int exit_opt; |
1140
|
|
|
|
|
|
SV *thread_exit_only; |
1141
|
|
|
|
|
|
char *str; |
1142
|
|
|
|
|
|
int idx; |
1143
|
|
|
|
|
|
dMY_POOL; |
1144
|
|
|
|
|
|
#line 1145 "threads.c" |
1145
|
|
|
|
|
|
#line 990 "threads.xs" |
1146
|
|
|
|
|
|
if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { |
1147
|
|
|
|
|
|
if (--items < 2) { |
1148
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)"); |
1149
|
|
|
|
|
|
} |
1150
|
|
|
|
|
|
specs = (HV*)SvRV(ST(1)); |
1151
|
|
|
|
|
|
idx = 1; |
1152
|
|
|
|
|
|
} else { |
1153
|
|
|
|
|
|
if (items < 2) { |
1154
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); |
1155
|
|
|
|
|
|
} |
1156
|
|
|
|
|
|
specs = NULL; |
1157
|
|
|
|
|
|
idx = 0; |
1158
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
if (sv_isobject(ST(0))) { |
1161
|
|
|
|
|
|
/* $thr->create() */ |
1162
|
|
|
|
|
|
classname = HvNAME(SvSTASH(SvRV(ST(0)))); |
1163
|
|
|
|
|
|
thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1164
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1165
|
|
|
|
|
|
stack_size = thread->stack_size; |
1166
|
|
|
|
|
|
exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; |
1167
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1168
|
|
|
|
|
|
} else { |
1169
|
|
|
|
|
|
/* threads->create() */ |
1170
|
|
|
|
|
|
classname = (char *)SvPV_nolen(ST(0)); |
1171
|
|
|
|
|
|
stack_size = MY_POOL.default_stack_size; |
1172
|
|
|
|
|
|
thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD); |
1173
|
|
|
|
|
|
exit_opt = (SvTRUE(thread_exit_only)) |
1174
|
|
|
|
|
|
? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
1175
|
|
|
|
|
|
} |
1176
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
function_to_call = ST(idx+1); |
1178
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
context = -1; |
1180
|
|
|
|
|
|
if (specs) { |
1181
|
|
|
|
|
|
SV **svp; |
1182
|
|
|
|
|
|
/* stack_size */ |
1183
|
|
|
|
|
|
if ((svp = hv_fetch(specs, "stack", 5, 0))) { |
1184
|
|
|
|
|
|
stack_size = SvIV(*svp); |
1185
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "stacksize", 9, 0))) { |
1186
|
|
|
|
|
|
stack_size = SvIV(*svp); |
1187
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "stack_size", 10, 0))) { |
1188
|
|
|
|
|
|
stack_size = SvIV(*svp); |
1189
|
|
|
|
|
|
} |
1190
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
/* context */ |
1192
|
|
|
|
|
|
if ((svp = hv_fetch(specs, "context", 7, 0))) { |
1193
|
|
|
|
|
|
str = (char *)SvPV_nolen(*svp); |
1194
|
|
|
|
|
|
switch (*str) { |
1195
|
|
|
|
|
|
case 'a': |
1196
|
|
|
|
|
|
case 'A': |
1197
|
|
|
|
|
|
case 'l': |
1198
|
|
|
|
|
|
case 'L': |
1199
|
|
|
|
|
|
context = G_ARRAY; |
1200
|
|
|
|
|
|
break; |
1201
|
|
|
|
|
|
case 's': |
1202
|
|
|
|
|
|
case 'S': |
1203
|
|
|
|
|
|
context = G_SCALAR; |
1204
|
|
|
|
|
|
break; |
1205
|
|
|
|
|
|
case 'v': |
1206
|
|
|
|
|
|
case 'V': |
1207
|
|
|
|
|
|
context = G_VOID; |
1208
|
|
|
|
|
|
break; |
1209
|
|
|
|
|
|
default: |
1210
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid context: %s", str); |
1211
|
|
|
|
|
|
} |
1212
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "array", 5, 0))) { |
1213
|
|
|
|
|
|
if (SvTRUE(*svp)) { |
1214
|
|
|
|
|
|
context = G_ARRAY; |
1215
|
|
|
|
|
|
} |
1216
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "list", 4, 0))) { |
1217
|
|
|
|
|
|
if (SvTRUE(*svp)) { |
1218
|
|
|
|
|
|
context = G_ARRAY; |
1219
|
|
|
|
|
|
} |
1220
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "scalar", 6, 0))) { |
1221
|
|
|
|
|
|
if (SvTRUE(*svp)) { |
1222
|
|
|
|
|
|
context = G_SCALAR; |
1223
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
} else if ((svp = hv_fetch(specs, "void", 4, 0))) { |
1225
|
|
|
|
|
|
if (SvTRUE(*svp)) { |
1226
|
|
|
|
|
|
context = G_VOID; |
1227
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
} |
1229
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
/* exit => thread_only */ |
1231
|
|
|
|
|
|
if ((svp = hv_fetch(specs, "exit", 4, 0))) { |
1232
|
|
|
|
|
|
str = (char *)SvPV_nolen(*svp); |
1233
|
|
|
|
|
|
exit_opt = (*str == 't' || *str == 'T') |
1234
|
|
|
|
|
|
? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
1235
|
|
|
|
|
|
} |
1236
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
if (context == -1) { |
1238
|
|
|
|
|
|
context = GIMME_V; /* Implicit context */ |
1239
|
|
|
|
|
|
} else { |
1240
|
|
|
|
|
|
context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); |
1241
|
|
|
|
|
|
} |
1242
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
/* Create thread */ |
1244
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1245
|
|
|
|
|
|
thread = S_ithread_create(aTHX_ function_to_call, |
1246
|
|
|
|
|
|
stack_size, |
1247
|
|
|
|
|
|
context, |
1248
|
|
|
|
|
|
exit_opt, |
1249
|
|
|
|
|
|
ax + idx + 2, |
1250
|
|
|
|
|
|
items > 2 ? items - 2 : 0); |
1251
|
|
|
|
|
|
if (! thread) { |
1252
|
|
|
|
|
|
XSRETURN_UNDEF; /* Mutex already unlocked */ |
1253
|
|
|
|
|
|
} |
1254
|
|
|
|
|
|
ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); |
1255
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1256
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
/* Let thread run */ |
1258
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1259
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1261
|
|
|
|
|
|
#line 1262 "threads.c" |
1262
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
XSRETURN(1); |
1264
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
XS_EUPXS(XS_threads_list); /* prototype to pass -Wmissing-prototypes */ |
1268
|
|
|
|
|
|
XS_EUPXS(XS_threads_list) |
1269
|
|
|
|
|
|
{ |
1270
|
|
|
|
|
|
dVAR; dXSARGS; |
1271
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1272
|
|
|
|
|
|
PERL_UNUSED_VAR(ax); /* -Wall */ |
1273
|
|
|
|
|
|
SP -= items; |
1274
|
|
|
|
|
|
{ |
1275
|
|
|
|
|
|
#line 1110 "threads.xs" |
1276
|
|
|
|
|
|
char *classname; |
1277
|
|
|
|
|
|
ithread *thread; |
1278
|
|
|
|
|
|
int list_context; |
1279
|
|
|
|
|
|
IV count = 0; |
1280
|
|
|
|
|
|
int want_running = 0; |
1281
|
|
|
|
|
|
int state; |
1282
|
|
|
|
|
|
dMY_POOL; |
1283
|
|
|
|
|
|
#line 1284 "threads.c" |
1284
|
|
|
|
|
|
#line 1118 "threads.xs" |
1285
|
|
|
|
|
|
/* Class method only */ |
1286
|
|
|
|
|
|
if (SvROK(ST(0))) { |
1287
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->list(...)"); |
1288
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
classname = (char *)SvPV_nolen(ST(0)); |
1290
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
/* Calling context */ |
1292
|
|
|
|
|
|
list_context = (GIMME_V == G_ARRAY); |
1293
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
/* Running or joinable parameter */ |
1295
|
|
|
|
|
|
if (items > 1) { |
1296
|
|
|
|
|
|
want_running = SvTRUE(ST(1)); |
1297
|
|
|
|
|
|
} |
1298
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
/* Walk through threads list */ |
1300
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1301
|
|
|
|
|
|
for (thread = MY_POOL.main_thread.next; |
1302
|
|
|
|
|
|
thread != &MY_POOL.main_thread; |
1303
|
|
|
|
|
|
thread = thread->next) |
1304
|
|
|
|
|
|
{ |
1305
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1306
|
|
|
|
|
|
state = thread->state; |
1307
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1308
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
/* Ignore detached or joined threads */ |
1310
|
|
|
|
|
|
if (state & PERL_ITHR_UNCALLABLE) { |
1311
|
|
|
|
|
|
continue; |
1312
|
|
|
|
|
|
} |
1313
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
/* Filter per parameter */ |
1315
|
|
|
|
|
|
if (items > 1) { |
1316
|
|
|
|
|
|
if (want_running) { |
1317
|
|
|
|
|
|
if (state & PERL_ITHR_FINISHED) { |
1318
|
|
|
|
|
|
continue; /* Not running */ |
1319
|
|
|
|
|
|
} |
1320
|
|
|
|
|
|
} else { |
1321
|
|
|
|
|
|
if (! (state & PERL_ITHR_FINISHED)) { |
1322
|
|
|
|
|
|
continue; /* Still running - not joinable yet */ |
1323
|
|
|
|
|
|
} |
1324
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
} |
1326
|
|
|
|
|
|
|
1327
|
|
|
|
|
|
/* Push object on stack if list context */ |
1328
|
|
|
|
|
|
if (list_context) { |
1329
|
|
|
|
|
|
XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); |
1330
|
|
|
|
|
|
} |
1331
|
|
|
|
|
|
count++; |
1332
|
|
|
|
|
|
} |
1333
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1334
|
|
|
|
|
|
/* If scalar context, send back count */ |
1335
|
|
|
|
|
|
if (! list_context) { |
1336
|
|
|
|
|
|
XSRETURN_IV(count); |
1337
|
|
|
|
|
|
} |
1338
|
|
|
|
|
|
#line 1339 "threads.c" |
1339
|
|
|
|
|
|
PUTBACK; |
1340
|
|
|
|
|
|
return; |
1341
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
XS_EUPXS(XS_threads_self); /* prototype to pass -Wmissing-prototypes */ |
1346
|
|
|
|
|
|
XS_EUPXS(XS_threads_self) |
1347
|
|
|
|
|
|
{ |
1348
|
|
|
|
|
|
dVAR; dXSARGS; |
1349
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1350
|
|
|
|
|
|
{ |
1351
|
|
|
|
|
|
#line 1176 "threads.xs" |
1352
|
|
|
|
|
|
char *classname; |
1353
|
|
|
|
|
|
ithread *thread; |
1354
|
|
|
|
|
|
#line 1355 "threads.c" |
1355
|
|
|
|
|
|
#line 1179 "threads.xs" |
1356
|
|
|
|
|
|
/* Class method only */ |
1357
|
|
|
|
|
|
if ((items != 1) || SvROK(ST(0))) { |
1358
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->self()"); |
1359
|
|
|
|
|
|
} |
1360
|
|
|
|
|
|
classname = (char *)SvPV_nolen(ST(0)); |
1361
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
thread = S_ithread_get(aTHX); |
1363
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
1365
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1366
|
|
|
|
|
|
#line 1367 "threads.c" |
1367
|
|
|
|
|
|
} |
1368
|
|
|
|
|
|
XSRETURN(1); |
1369
|
|
|
|
|
|
} |
1370
|
|
|
|
|
|
|
1371
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
XS_EUPXS(XS_threads_tid); /* prototype to pass -Wmissing-prototypes */ |
1373
|
|
|
|
|
|
XS_EUPXS(XS_threads_tid) |
1374
|
|
|
|
|
|
{ |
1375
|
|
|
|
|
|
dVAR; dXSARGS; |
1376
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1377
|
|
|
|
|
|
{ |
1378
|
|
|
|
|
|
#line 1194 "threads.xs" |
1379
|
|
|
|
|
|
ithread *thread; |
1380
|
|
|
|
|
|
#line 1381 "threads.c" |
1381
|
|
|
|
|
|
#line 1196 "threads.xs" |
1382
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1383
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1384
|
|
|
|
|
|
XST_mUV(0, thread->tid); |
1385
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1386
|
|
|
|
|
|
#line 1387 "threads.c" |
1387
|
|
|
|
|
|
} |
1388
|
|
|
|
|
|
XSRETURN(1); |
1389
|
|
|
|
|
|
} |
1390
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
XS_EUPXS(XS_threads_join); /* prototype to pass -Wmissing-prototypes */ |
1393
|
|
|
|
|
|
XS_EUPXS(XS_threads_join) |
1394
|
|
|
|
|
|
{ |
1395
|
|
|
|
|
|
dVAR; dXSARGS; |
1396
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1397
|
|
|
|
|
|
PERL_UNUSED_VAR(ax); /* -Wall */ |
1398
|
|
|
|
|
|
SP -= items; |
1399
|
|
|
|
|
|
{ |
1400
|
|
|
|
|
|
#line 1205 "threads.xs" |
1401
|
|
|
|
|
|
ithread *thread; |
1402
|
|
|
|
|
|
ithread *current_thread; |
1403
|
|
|
|
|
|
int join_err; |
1404
|
|
|
|
|
|
AV *params = NULL; |
1405
|
|
|
|
|
|
int len; |
1406
|
|
|
|
|
|
int ii; |
1407
|
|
|
|
|
|
#ifndef WIN32 |
1408
|
|
|
|
|
|
int rc_join; |
1409
|
|
|
|
|
|
void *retval; |
1410
|
|
|
|
|
|
#endif |
1411
|
|
|
|
|
|
dMY_POOL; |
1412
|
|
|
|
|
|
#line 1413 "threads.c" |
1413
|
|
|
|
|
|
#line 1217 "threads.xs" |
1414
|
|
|
|
|
|
/* Object method only */ |
1415
|
|
|
|
|
|
if ((items != 1) || ! sv_isobject(ST(0))) { |
1416
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: $thr->join()"); |
1417
|
|
|
|
|
|
} |
1418
|
|
|
|
|
|
|
1419
|
|
|
|
|
|
/* Check if the thread is joinable and not ourselves */ |
1420
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1421
|
|
|
|
|
|
current_thread = S_ithread_get(aTHX); |
1422
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1424
|
|
|
|
|
|
if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) { |
1425
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1426
|
|
|
|
|
|
Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED) |
1427
|
|
|
|
|
|
? "Cannot join a detached thread" |
1428
|
|
|
|
|
|
: "Thread already joined"); |
1429
|
|
|
|
|
|
} else if (thread->tid == current_thread->tid) { |
1430
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1431
|
|
|
|
|
|
Perl_croak(aTHX_ "Cannot join self"); |
1432
|
|
|
|
|
|
} |
1433
|
|
|
|
|
|
|
1434
|
|
|
|
|
|
/* Mark as joined */ |
1435
|
|
|
|
|
|
thread->state |= PERL_ITHR_JOINED; |
1436
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1437
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1439
|
|
|
|
|
|
MY_POOL.joinable_threads--; |
1440
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1441
|
|
|
|
|
|
|
1442
|
|
|
|
|
|
/* Join the thread */ |
1443
|
|
|
|
|
|
#ifdef WIN32 |
1444
|
|
|
|
|
|
if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) { |
1445
|
|
|
|
|
|
/* Timeout/abandonment unexpected here; check $^E */ |
1446
|
|
|
|
|
|
Perl_croak(aTHX_ "PANIC: underlying join failed"); |
1447
|
|
|
|
|
|
}; |
1448
|
|
|
|
|
|
#else |
1449
|
|
|
|
|
|
if ((rc_join = pthread_join(thread->thr, &retval)) != 0) { |
1450
|
|
|
|
|
|
/* In progress/deadlock/unknown unexpected here; check $! */ |
1451
|
|
|
|
|
|
errno = rc_join; |
1452
|
|
|
|
|
|
Perl_croak(aTHX_ "PANIC: underlying join failed"); |
1453
|
|
|
|
|
|
}; |
1454
|
|
|
|
|
|
#endif |
1455
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1457
|
|
|
|
|
|
/* Get the return value from the call_sv */ |
1458
|
|
|
|
|
|
/* Objects do not survive this process - FIXME */ |
1459
|
|
|
|
|
|
if ((thread->gimme & G_WANT) != G_VOID) { |
1460
|
|
|
|
|
|
#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) |
1461
|
|
|
|
|
|
AV *params_copy; |
1462
|
|
|
|
|
|
PerlInterpreter *other_perl; |
1463
|
|
|
|
|
|
CLONE_PARAMS clone_params; |
1464
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
params_copy = thread->params; |
1466
|
|
|
|
|
|
other_perl = thread->interp; |
1467
|
|
|
|
|
|
clone_params.stashes = newAV(); |
1468
|
|
|
|
|
|
clone_params.flags = CLONEf_JOIN_IN; |
1469
|
|
|
|
|
|
PL_ptr_table = ptr_table_new(); |
1470
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
1471
|
|
|
|
|
|
/* Ensure 'meaningful' addresses retain their meaning */ |
1472
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
1473
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
1474
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
1475
|
|
|
|
|
|
params = (AV *)sv_dup((SV*)params_copy, &clone_params); |
1476
|
|
|
|
|
|
S_ithread_set(aTHX_ current_thread); |
1477
|
|
|
|
|
|
SvREFCNT_dec(clone_params.stashes); |
1478
|
|
|
|
|
|
SvREFCNT_inc_void(params); |
1479
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
1480
|
|
|
|
|
|
PL_ptr_table = NULL; |
1481
|
|
|
|
|
|
#else |
1482
|
|
|
|
|
|
AV *params_copy; |
1483
|
|
|
|
|
|
PerlInterpreter *other_perl = thread->interp; |
1484
|
|
|
|
|
|
CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX); |
1485
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
params_copy = thread->params; |
1487
|
|
|
|
|
|
clone_params->flags |= CLONEf_JOIN_IN; |
1488
|
|
|
|
|
|
PL_ptr_table = ptr_table_new(); |
1489
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
1490
|
|
|
|
|
|
/* Ensure 'meaningful' addresses retain their meaning */ |
1491
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
1492
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
1493
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
1494
|
|
|
|
|
|
params = (AV *)sv_dup((SV*)params_copy, clone_params); |
1495
|
|
|
|
|
|
S_ithread_set(aTHX_ current_thread); |
1496
|
|
|
|
|
|
Perl_clone_params_del(clone_params); |
1497
|
|
|
|
|
|
SvREFCNT_inc_void(params); |
1498
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
1499
|
|
|
|
|
|
PL_ptr_table = NULL; |
1500
|
|
|
|
|
|
#endif |
1501
|
|
|
|
|
|
} |
1502
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
/* If thread didn't die, then we can free its interpreter */ |
1504
|
|
|
|
|
|
if (! (thread->state & PERL_ITHR_DIED)) { |
1505
|
|
|
|
|
|
S_ithread_clear(aTHX_ thread); |
1506
|
|
|
|
|
|
} |
1507
|
|
|
|
|
|
S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
1508
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
/* If no return values, then just return */ |
1510
|
|
|
|
|
|
if (! params) { |
1511
|
|
|
|
|
|
XSRETURN_UNDEF; |
1512
|
|
|
|
|
|
} |
1513
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
/* Put return values on stack */ |
1515
|
|
|
|
|
|
len = (int)AvFILL(params); |
1516
|
|
|
|
|
|
for (ii=0; ii <= len; ii++) { |
1517
|
|
|
|
|
|
SV* param = av_shift(params); |
1518
|
|
|
|
|
|
XPUSHs(sv_2mortal(param)); |
1519
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
|
1521
|
|
|
|
|
|
/* Free return value array */ |
1522
|
|
|
|
|
|
SvREFCNT_dec(params); |
1523
|
|
|
|
|
|
#line 1524 "threads.c" |
1524
|
|
|
|
|
|
PUTBACK; |
1525
|
|
|
|
|
|
return; |
1526
|
|
|
|
|
|
} |
1527
|
|
|
|
|
|
} |
1528
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
XS_EUPXS(XS_threads_yield); /* prototype to pass -Wmissing-prototypes */ |
1531
|
|
|
|
|
|
XS_EUPXS(XS_threads_yield) |
1532
|
|
|
|
|
|
{ |
1533
|
|
|
|
|
|
dVAR; dXSARGS; |
1534
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1535
|
|
|
|
|
|
{ |
1536
|
|
|
|
|
|
#line 1331 "threads.xs" |
1537
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1538
|
|
|
|
|
|
YIELD; |
1539
|
|
|
|
|
|
#line 1540 "threads.c" |
1540
|
|
|
|
|
|
} |
1541
|
|
|
|
|
|
XSRETURN_EMPTY; |
1542
|
|
|
|
|
|
} |
1543
|
|
|
|
|
|
|
1544
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
XS_EUPXS(XS_threads_detach); /* prototype to pass -Wmissing-prototypes */ |
1546
|
|
|
|
|
|
XS_EUPXS(XS_threads_detach) |
1547
|
|
|
|
|
|
{ |
1548
|
|
|
|
|
|
dVAR; dXSARGS; |
1549
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1550
|
|
|
|
|
|
{ |
1551
|
|
|
|
|
|
#line 1338 "threads.xs" |
1552
|
|
|
|
|
|
ithread *thread; |
1553
|
|
|
|
|
|
int detach_err; |
1554
|
|
|
|
|
|
dMY_POOL; |
1555
|
|
|
|
|
|
#line 1556 "threads.c" |
1556
|
|
|
|
|
|
#line 1342 "threads.xs" |
1557
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1558
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
/* Detach the thread */ |
1560
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1561
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1562
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1563
|
|
|
|
|
|
if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) { |
1564
|
|
|
|
|
|
/* Thread is detachable */ |
1565
|
|
|
|
|
|
thread->state |= PERL_ITHR_DETACHED; |
1566
|
|
|
|
|
|
#ifdef WIN32 |
1567
|
|
|
|
|
|
/* Windows has no 'detach thread' function */ |
1568
|
|
|
|
|
|
#else |
1569
|
|
|
|
|
|
PERL_THREAD_DETACH(thread->thr); |
1570
|
|
|
|
|
|
#endif |
1571
|
|
|
|
|
|
if (thread->state & PERL_ITHR_FINISHED) { |
1572
|
|
|
|
|
|
MY_POOL.joinable_threads--; |
1573
|
|
|
|
|
|
} else { |
1574
|
|
|
|
|
|
MY_POOL.running_threads--; |
1575
|
|
|
|
|
|
MY_POOL.detached_threads++; |
1576
|
|
|
|
|
|
} |
1577
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1579
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1580
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
if (detach_err) { |
1582
|
|
|
|
|
|
Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED) |
1583
|
|
|
|
|
|
? "Thread already detached" |
1584
|
|
|
|
|
|
: "Cannot detach a joined thread"); |
1585
|
|
|
|
|
|
} |
1586
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
/* If thread is finished and didn't die, |
1588
|
|
|
|
|
|
* then we can free its interpreter */ |
1589
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1590
|
|
|
|
|
|
if ((thread->state & PERL_ITHR_FINISHED) && |
1591
|
|
|
|
|
|
! (thread->state & PERL_ITHR_DIED)) |
1592
|
|
|
|
|
|
{ |
1593
|
|
|
|
|
|
S_ithread_clear(aTHX_ thread); |
1594
|
|
|
|
|
|
} |
1595
|
|
|
|
|
|
S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
1596
|
|
|
|
|
|
#line 1597 "threads.c" |
1597
|
|
|
|
|
|
} |
1598
|
|
|
|
|
|
XSRETURN_EMPTY; |
1599
|
|
|
|
|
|
} |
1600
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
XS_EUPXS(XS_threads_kill); /* prototype to pass -Wmissing-prototypes */ |
1603
|
|
|
|
|
|
XS_EUPXS(XS_threads_kill) |
1604
|
|
|
|
|
|
{ |
1605
|
|
|
|
|
|
dVAR; dXSARGS; |
1606
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1607
|
|
|
|
|
|
{ |
1608
|
|
|
|
|
|
#line 1386 "threads.xs" |
1609
|
|
|
|
|
|
ithread *thread; |
1610
|
|
|
|
|
|
char *sig_name; |
1611
|
|
|
|
|
|
IV signal; |
1612
|
|
|
|
|
|
int no_handler = 1; |
1613
|
|
|
|
|
|
#line 1614 "threads.c" |
1614
|
|
|
|
|
|
#line 1391 "threads.xs" |
1615
|
|
|
|
|
|
/* Must have safe signals */ |
1616
|
|
|
|
|
|
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
1617
|
|
|
|
|
|
Perl_croak(aTHX_ "Cannot signal threads without safe signals"); |
1618
|
|
|
|
|
|
} |
1619
|
|
|
|
|
|
|
1620
|
|
|
|
|
|
/* Object method only */ |
1621
|
|
|
|
|
|
if ((items != 2) || ! sv_isobject(ST(0))) { |
1622
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); |
1623
|
|
|
|
|
|
} |
1624
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
/* Get signal */ |
1626
|
|
|
|
|
|
sig_name = SvPV_nolen(ST(1)); |
1627
|
|
|
|
|
|
if (isALPHA(*sig_name)) { |
1628
|
|
|
|
|
|
if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') { |
1629
|
|
|
|
|
|
sig_name += 3; |
1630
|
|
|
|
|
|
} |
1631
|
|
|
|
|
|
if ((signal = whichsig(sig_name)) < 0) { |
1632
|
|
|
|
|
|
Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name); |
1633
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
} else { |
1635
|
|
|
|
|
|
signal = SvIV(ST(1)); |
1636
|
|
|
|
|
|
} |
1637
|
|
|
|
|
|
|
1638
|
|
|
|
|
|
/* Set the signal for the thread */ |
1639
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1640
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1641
|
|
|
|
|
|
if (thread->interp && ! (thread->state & PERL_ITHR_FINISHED)) { |
1642
|
|
|
|
|
|
dTHXa(thread->interp); |
1643
|
|
|
|
|
|
if (PL_psig_pend && PL_psig_ptr[signal]) { |
1644
|
|
|
|
|
|
PL_psig_pend[signal]++; |
1645
|
|
|
|
|
|
PL_sig_pending = 1; |
1646
|
|
|
|
|
|
no_handler = 0; |
1647
|
|
|
|
|
|
} |
1648
|
|
|
|
|
|
} else { |
1649
|
|
|
|
|
|
/* Ignore signal to terminated/finished thread */ |
1650
|
|
|
|
|
|
no_handler = 0; |
1651
|
|
|
|
|
|
} |
1652
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1653
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
if (no_handler) { |
1655
|
|
|
|
|
|
Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid); |
1656
|
|
|
|
|
|
} |
1657
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
/* Return the thread to allow for method chaining */ |
1659
|
|
|
|
|
|
ST(0) = ST(0); |
1660
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1661
|
|
|
|
|
|
#line 1662 "threads.c" |
1662
|
|
|
|
|
|
} |
1663
|
|
|
|
|
|
XSRETURN(1); |
1664
|
|
|
|
|
|
} |
1665
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
1667
|
|
|
|
|
|
XS_EUPXS(XS_threads_DESTROY); /* prototype to pass -Wmissing-prototypes */ |
1668
|
|
|
|
|
|
XS_EUPXS(XS_threads_DESTROY) |
1669
|
|
|
|
|
|
{ |
1670
|
|
|
|
|
|
dVAR; dXSARGS; |
1671
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1672
|
|
|
|
|
|
{ |
1673
|
|
|
|
|
|
#line 1442 "threads.xs" |
1674
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1675
|
|
|
|
|
|
sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); |
1676
|
|
|
|
|
|
#line 1677 "threads.c" |
1677
|
|
|
|
|
|
} |
1678
|
|
|
|
|
|
XSRETURN_EMPTY; |
1679
|
|
|
|
|
|
} |
1680
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
1682
|
|
|
|
|
|
XS_EUPXS(XS_threads_equal); /* prototype to pass -Wmissing-prototypes */ |
1683
|
|
|
|
|
|
XS_EUPXS(XS_threads_equal) |
1684
|
|
|
|
|
|
{ |
1685
|
|
|
|
|
|
dVAR; dXSARGS; |
1686
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1687
|
|
|
|
|
|
{ |
1688
|
|
|
|
|
|
#line 1449 "threads.xs" |
1689
|
|
|
|
|
|
int are_equal = 0; |
1690
|
|
|
|
|
|
#line 1691 "threads.c" |
1691
|
|
|
|
|
|
#line 1451 "threads.xs" |
1692
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1693
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
/* Compares TIDs to determine thread equality */ |
1695
|
|
|
|
|
|
if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { |
1696
|
|
|
|
|
|
ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1697
|
|
|
|
|
|
ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); |
1698
|
|
|
|
|
|
are_equal = (thr1->tid == thr2->tid); |
1699
|
|
|
|
|
|
} |
1700
|
|
|
|
|
|
if (are_equal) { |
1701
|
|
|
|
|
|
XST_mYES(0); |
1702
|
|
|
|
|
|
} else { |
1703
|
|
|
|
|
|
/* Return 0 on false for backward compatibility */ |
1704
|
|
|
|
|
|
XST_mIV(0, 0); |
1705
|
|
|
|
|
|
} |
1706
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1707
|
|
|
|
|
|
#line 1708 "threads.c" |
1708
|
|
|
|
|
|
} |
1709
|
|
|
|
|
|
XSRETURN(1); |
1710
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
XS_EUPXS(XS_threads_object); /* prototype to pass -Wmissing-prototypes */ |
1714
|
|
|
|
|
|
XS_EUPXS(XS_threads_object) |
1715
|
|
|
|
|
|
{ |
1716
|
|
|
|
|
|
dVAR; dXSARGS; |
1717
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1718
|
|
|
|
|
|
{ |
1719
|
|
|
|
|
|
#line 1471 "threads.xs" |
1720
|
|
|
|
|
|
char *classname; |
1721
|
|
|
|
|
|
SV *arg; |
1722
|
|
|
|
|
|
UV tid; |
1723
|
|
|
|
|
|
ithread *thread; |
1724
|
|
|
|
|
|
int state; |
1725
|
|
|
|
|
|
int have_obj = 0; |
1726
|
|
|
|
|
|
dMY_POOL; |
1727
|
|
|
|
|
|
#line 1728 "threads.c" |
1728
|
|
|
|
|
|
#line 1479 "threads.xs" |
1729
|
|
|
|
|
|
/* Class method only */ |
1730
|
|
|
|
|
|
if (SvROK(ST(0))) { |
1731
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->object($tid)"); |
1732
|
|
|
|
|
|
} |
1733
|
|
|
|
|
|
classname = (char *)SvPV_nolen(ST(0)); |
1734
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
/* Turn $tid from PVLV to SV if needed (bug #73330) */ |
1736
|
|
|
|
|
|
arg = ST(1); |
1737
|
|
|
|
|
|
SvGETMAGIC(arg); |
1738
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
if ((items < 2) || ! SvOK(arg)) { |
1740
|
|
|
|
|
|
XSRETURN_UNDEF; |
1741
|
|
|
|
|
|
} |
1742
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
/* threads->object($tid) */ |
1744
|
|
|
|
|
|
tid = SvUV(arg); |
1745
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
/* If current thread wants its own object, then behave the same as |
1747
|
|
|
|
|
|
->self() */ |
1748
|
|
|
|
|
|
thread = S_ithread_get(aTHX); |
1749
|
|
|
|
|
|
if (thread->tid == tid) { |
1750
|
|
|
|
|
|
ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
1751
|
|
|
|
|
|
have_obj = 1; |
1752
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
} else { |
1754
|
|
|
|
|
|
/* Walk through threads list */ |
1755
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1756
|
|
|
|
|
|
for (thread = MY_POOL.main_thread.next; |
1757
|
|
|
|
|
|
thread != &MY_POOL.main_thread; |
1758
|
|
|
|
|
|
thread = thread->next) |
1759
|
|
|
|
|
|
{ |
1760
|
|
|
|
|
|
/* Look for TID */ |
1761
|
|
|
|
|
|
if (thread->tid == tid) { |
1762
|
|
|
|
|
|
/* Ignore if detached or joined */ |
1763
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1764
|
|
|
|
|
|
state = thread->state; |
1765
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1766
|
|
|
|
|
|
if (! (state & PERL_ITHR_UNCALLABLE)) { |
1767
|
|
|
|
|
|
/* Put object on stack */ |
1768
|
|
|
|
|
|
ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
1769
|
|
|
|
|
|
have_obj = 1; |
1770
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
break; |
1772
|
|
|
|
|
|
} |
1773
|
|
|
|
|
|
} |
1774
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1775
|
|
|
|
|
|
} |
1776
|
|
|
|
|
|
|
1777
|
|
|
|
|
|
if (! have_obj) { |
1778
|
|
|
|
|
|
XSRETURN_UNDEF; |
1779
|
|
|
|
|
|
} |
1780
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1781
|
|
|
|
|
|
#line 1782 "threads.c" |
1782
|
|
|
|
|
|
} |
1783
|
|
|
|
|
|
XSRETURN(1); |
1784
|
|
|
|
|
|
} |
1785
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
1787
|
|
|
|
|
|
XS_EUPXS(XS_threads__handle); /* prototype to pass -Wmissing-prototypes */ |
1788
|
|
|
|
|
|
XS_EUPXS(XS_threads__handle) |
1789
|
|
|
|
|
|
{ |
1790
|
|
|
|
|
|
dVAR; dXSARGS; |
1791
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1792
|
|
|
|
|
|
{ |
1793
|
|
|
|
|
|
#line 1536 "threads.xs" |
1794
|
|
|
|
|
|
ithread *thread; |
1795
|
|
|
|
|
|
#line 1796 "threads.c" |
1796
|
|
|
|
|
|
#line 1538 "threads.xs" |
1797
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1798
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1799
|
|
|
|
|
|
#ifdef WIN32 |
1800
|
|
|
|
|
|
XST_mUV(0, PTR2UV(&thread->handle)); |
1801
|
|
|
|
|
|
#else |
1802
|
|
|
|
|
|
XST_mUV(0, PTR2UV(&thread->thr)); |
1803
|
|
|
|
|
|
#endif |
1804
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1805
|
|
|
|
|
|
#line 1806 "threads.c" |
1806
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
XSRETURN(1); |
1808
|
|
|
|
|
|
} |
1809
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
XS_EUPXS(XS_threads_get_stack_size); /* prototype to pass -Wmissing-prototypes */ |
1812
|
|
|
|
|
|
XS_EUPXS(XS_threads_get_stack_size) |
1813
|
|
|
|
|
|
{ |
1814
|
|
|
|
|
|
dVAR; dXSARGS; |
1815
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1816
|
|
|
|
|
|
{ |
1817
|
|
|
|
|
|
#line 1551 "threads.xs" |
1818
|
|
|
|
|
|
IV stack_size; |
1819
|
|
|
|
|
|
dMY_POOL; |
1820
|
|
|
|
|
|
#line 1821 "threads.c" |
1821
|
|
|
|
|
|
#line 1554 "threads.xs" |
1822
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1823
|
|
|
|
|
|
if (sv_isobject(ST(0))) { |
1824
|
|
|
|
|
|
/* $thr->get_stack_size() */ |
1825
|
|
|
|
|
|
ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1826
|
|
|
|
|
|
stack_size = thread->stack_size; |
1827
|
|
|
|
|
|
} else { |
1828
|
|
|
|
|
|
/* threads->get_stack_size() */ |
1829
|
|
|
|
|
|
stack_size = MY_POOL.default_stack_size; |
1830
|
|
|
|
|
|
} |
1831
|
|
|
|
|
|
XST_mIV(0, stack_size); |
1832
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1833
|
|
|
|
|
|
#line 1834 "threads.c" |
1834
|
|
|
|
|
|
} |
1835
|
|
|
|
|
|
XSRETURN(1); |
1836
|
|
|
|
|
|
} |
1837
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
XS_EUPXS(XS_threads_set_stack_size); /* prototype to pass -Wmissing-prototypes */ |
1840
|
|
|
|
|
|
XS_EUPXS(XS_threads_set_stack_size) |
1841
|
|
|
|
|
|
{ |
1842
|
|
|
|
|
|
dVAR; dXSARGS; |
1843
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1844
|
|
|
|
|
|
{ |
1845
|
|
|
|
|
|
#line 1570 "threads.xs" |
1846
|
|
|
|
|
|
IV old_size; |
1847
|
|
|
|
|
|
dMY_POOL; |
1848
|
|
|
|
|
|
#line 1849 "threads.c" |
1849
|
|
|
|
|
|
#line 1573 "threads.xs" |
1850
|
|
|
|
|
|
if (items != 2) { |
1851
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)"); |
1852
|
|
|
|
|
|
} |
1853
|
|
|
|
|
|
if (sv_isobject(ST(0))) { |
1854
|
|
|
|
|
|
Perl_croak(aTHX_ "Cannot change stack size of an existing thread"); |
1855
|
|
|
|
|
|
} |
1856
|
|
|
|
|
|
if (! looks_like_number(ST(1))) { |
1857
|
|
|
|
|
|
Perl_croak(aTHX_ "Stack size must be numeric"); |
1858
|
|
|
|
|
|
} |
1859
|
|
|
|
|
|
|
1860
|
|
|
|
|
|
old_size = MY_POOL.default_stack_size; |
1861
|
|
|
|
|
|
MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1))); |
1862
|
|
|
|
|
|
XST_mIV(0, old_size); |
1863
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1864
|
|
|
|
|
|
#line 1865 "threads.c" |
1865
|
|
|
|
|
|
} |
1866
|
|
|
|
|
|
XSRETURN(1); |
1867
|
|
|
|
|
|
} |
1868
|
|
|
|
|
|
|
1869
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_running); /* prototype to pass -Wmissing-prototypes */ |
1871
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_running) |
1872
|
|
|
|
|
|
{ |
1873
|
|
|
|
|
|
dVAR; dXSARGS; |
1874
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1875
|
|
|
|
|
|
{ |
1876
|
|
|
|
|
|
#line 1592 "threads.xs" |
1877
|
|
|
|
|
|
ithread *thread; |
1878
|
|
|
|
|
|
#line 1879 "threads.c" |
1879
|
|
|
|
|
|
#line 1594 "threads.xs" |
1880
|
|
|
|
|
|
/* Object method only */ |
1881
|
|
|
|
|
|
if ((items != 1) || ! sv_isobject(ST(0))) { |
1882
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: $thr->is_running()"); |
1883
|
|
|
|
|
|
} |
1884
|
|
|
|
|
|
|
1885
|
|
|
|
|
|
thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1886
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1887
|
|
|
|
|
|
ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; |
1888
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1889
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1890
|
|
|
|
|
|
#line 1891 "threads.c" |
1891
|
|
|
|
|
|
} |
1892
|
|
|
|
|
|
XSRETURN(1); |
1893
|
|
|
|
|
|
} |
1894
|
|
|
|
|
|
|
1895
|
|
|
|
|
|
|
1896
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_detached); /* prototype to pass -Wmissing-prototypes */ |
1897
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_detached) |
1898
|
|
|
|
|
|
{ |
1899
|
|
|
|
|
|
dVAR; dXSARGS; |
1900
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1901
|
|
|
|
|
|
{ |
1902
|
|
|
|
|
|
#line 1609 "threads.xs" |
1903
|
|
|
|
|
|
ithread *thread; |
1904
|
|
|
|
|
|
#line 1905 "threads.c" |
1905
|
|
|
|
|
|
#line 1611 "threads.xs" |
1906
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1907
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1908
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1909
|
|
|
|
|
|
ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; |
1910
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1911
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1912
|
|
|
|
|
|
#line 1913 "threads.c" |
1913
|
|
|
|
|
|
} |
1914
|
|
|
|
|
|
XSRETURN(1); |
1915
|
|
|
|
|
|
} |
1916
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
1918
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_joinable); /* prototype to pass -Wmissing-prototypes */ |
1919
|
|
|
|
|
|
XS_EUPXS(XS_threads_is_joinable) |
1920
|
|
|
|
|
|
{ |
1921
|
|
|
|
|
|
dVAR; dXSARGS; |
1922
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1923
|
|
|
|
|
|
{ |
1924
|
|
|
|
|
|
#line 1622 "threads.xs" |
1925
|
|
|
|
|
|
ithread *thread; |
1926
|
|
|
|
|
|
#line 1927 "threads.c" |
1927
|
|
|
|
|
|
#line 1624 "threads.xs" |
1928
|
|
|
|
|
|
/* Object method only */ |
1929
|
|
|
|
|
|
if ((items != 1) || ! sv_isobject(ST(0))) { |
1930
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); |
1931
|
|
|
|
|
|
} |
1932
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1934
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1935
|
|
|
|
|
|
ST(0) = ((thread->state & PERL_ITHR_FINISHED) && |
1936
|
|
|
|
|
|
! (thread->state & PERL_ITHR_UNCALLABLE)) |
1937
|
|
|
|
|
|
? &PL_sv_yes : &PL_sv_no; |
1938
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1939
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1940
|
|
|
|
|
|
#line 1941 "threads.c" |
1941
|
|
|
|
|
|
} |
1942
|
|
|
|
|
|
XSRETURN(1); |
1943
|
|
|
|
|
|
} |
1944
|
|
|
|
|
|
|
1945
|
|
|
|
|
|
|
1946
|
|
|
|
|
|
XS_EUPXS(XS_threads_wantarray); /* prototype to pass -Wmissing-prototypes */ |
1947
|
|
|
|
|
|
XS_EUPXS(XS_threads_wantarray) |
1948
|
|
|
|
|
|
{ |
1949
|
|
|
|
|
|
dVAR; dXSARGS; |
1950
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1951
|
|
|
|
|
|
{ |
1952
|
|
|
|
|
|
#line 1641 "threads.xs" |
1953
|
|
|
|
|
|
ithread *thread; |
1954
|
|
|
|
|
|
#line 1955 "threads.c" |
1955
|
|
|
|
|
|
#line 1643 "threads.xs" |
1956
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
1957
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1958
|
|
|
|
|
|
ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes : |
1959
|
|
|
|
|
|
((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef |
1960
|
|
|
|
|
|
/* G_SCALAR */ : &PL_sv_no; |
1961
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1962
|
|
|
|
|
|
#line 1963 "threads.c" |
1963
|
|
|
|
|
|
} |
1964
|
|
|
|
|
|
XSRETURN(1); |
1965
|
|
|
|
|
|
} |
1966
|
|
|
|
|
|
|
1967
|
|
|
|
|
|
|
1968
|
|
|
|
|
|
XS_EUPXS(XS_threads_set_thread_exit_only); /* prototype to pass -Wmissing-prototypes */ |
1969
|
|
|
|
|
|
XS_EUPXS(XS_threads_set_thread_exit_only) |
1970
|
|
|
|
|
|
{ |
1971
|
|
|
|
|
|
dVAR; dXSARGS; |
1972
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
1973
|
|
|
|
|
|
{ |
1974
|
|
|
|
|
|
#line 1654 "threads.xs" |
1975
|
|
|
|
|
|
ithread *thread; |
1976
|
|
|
|
|
|
#line 1977 "threads.c" |
1977
|
|
|
|
|
|
#line 1656 "threads.xs" |
1978
|
|
|
|
|
|
if (items != 2) { |
1979
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); |
1980
|
|
|
|
|
|
} |
1981
|
|
|
|
|
|
thread = S_SV_to_ithread(aTHX_ ST(0)); |
1982
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
1983
|
|
|
|
|
|
if (SvTRUE(ST(1))) { |
1984
|
|
|
|
|
|
thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; |
1985
|
|
|
|
|
|
} else { |
1986
|
|
|
|
|
|
thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; |
1987
|
|
|
|
|
|
} |
1988
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
1989
|
|
|
|
|
|
#line 1990 "threads.c" |
1990
|
|
|
|
|
|
} |
1991
|
|
|
|
|
|
XSRETURN(1); |
1992
|
|
|
|
|
|
} |
1993
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
1995
|
|
|
|
|
|
XS_EUPXS(XS_threads_error); /* prototype to pass -Wmissing-prototypes */ |
1996
|
|
|
|
|
|
XS_EUPXS(XS_threads_error) |
1997
|
|
|
|
|
|
{ |
1998
|
|
|
|
|
|
dVAR; dXSARGS; |
1999
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
2000
|
|
|
|
|
|
{ |
2001
|
|
|
|
|
|
#line 1672 "threads.xs" |
2002
|
|
|
|
|
|
ithread *thread; |
2003
|
|
|
|
|
|
SV *err = NULL; |
2004
|
|
|
|
|
|
#line 2005 "threads.c" |
2005
|
|
|
|
|
|
#line 1675 "threads.xs" |
2006
|
|
|
|
|
|
/* Object method only */ |
2007
|
|
|
|
|
|
if ((items != 1) || ! sv_isobject(ST(0))) { |
2008
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: $thr->err()"); |
2009
|
|
|
|
|
|
} |
2010
|
|
|
|
|
|
|
2011
|
|
|
|
|
|
thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
2012
|
|
|
|
|
|
MUTEX_LOCK(&thread->mutex); |
2013
|
|
|
|
|
|
|
2014
|
|
|
|
|
|
/* If thread died, then clone the error into the calling thread */ |
2015
|
|
|
|
|
|
if (thread->state & PERL_ITHR_DIED) { |
2016
|
|
|
|
|
|
#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) |
2017
|
|
|
|
|
|
PerlInterpreter *other_perl; |
2018
|
|
|
|
|
|
CLONE_PARAMS clone_params; |
2019
|
|
|
|
|
|
ithread *current_thread; |
2020
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
other_perl = thread->interp; |
2022
|
|
|
|
|
|
clone_params.stashes = newAV(); |
2023
|
|
|
|
|
|
clone_params.flags = CLONEf_JOIN_IN; |
2024
|
|
|
|
|
|
PL_ptr_table = ptr_table_new(); |
2025
|
|
|
|
|
|
current_thread = S_ithread_get(aTHX); |
2026
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
2027
|
|
|
|
|
|
/* Ensure 'meaningful' addresses retain their meaning */ |
2028
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
2029
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
2030
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
2031
|
|
|
|
|
|
err = sv_dup(thread->err, &clone_params); |
2032
|
|
|
|
|
|
S_ithread_set(aTHX_ current_thread); |
2033
|
|
|
|
|
|
SvREFCNT_dec(clone_params.stashes); |
2034
|
|
|
|
|
|
SvREFCNT_inc_void(err); |
2035
|
|
|
|
|
|
/* If error was an object, bless it into the correct class */ |
2036
|
|
|
|
|
|
if (thread->err_class) { |
2037
|
|
|
|
|
|
sv_bless(err, gv_stashpv(thread->err_class, 1)); |
2038
|
|
|
|
|
|
} |
2039
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
2040
|
|
|
|
|
|
PL_ptr_table = NULL; |
2041
|
|
|
|
|
|
#else |
2042
|
|
|
|
|
|
PerlInterpreter *other_perl = thread->interp; |
2043
|
|
|
|
|
|
CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX); |
2044
|
|
|
|
|
|
ithread *current_thread; |
2045
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
clone_params->flags |= CLONEf_JOIN_IN; |
2047
|
|
|
|
|
|
PL_ptr_table = ptr_table_new(); |
2048
|
|
|
|
|
|
current_thread = S_ithread_get(aTHX); |
2049
|
|
|
|
|
|
S_ithread_set(aTHX_ thread); |
2050
|
|
|
|
|
|
/* Ensure 'meaningful' addresses retain their meaning */ |
2051
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
2052
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
2053
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
2054
|
|
|
|
|
|
err = sv_dup(thread->err, clone_params); |
2055
|
|
|
|
|
|
S_ithread_set(aTHX_ current_thread); |
2056
|
|
|
|
|
|
Perl_clone_params_del(clone_params); |
2057
|
|
|
|
|
|
SvREFCNT_inc_void(err); |
2058
|
|
|
|
|
|
/* If error was an object, bless it into the correct class */ |
2059
|
|
|
|
|
|
if (thread->err_class) { |
2060
|
|
|
|
|
|
sv_bless(err, gv_stashpv(thread->err_class, 1)); |
2061
|
|
|
|
|
|
} |
2062
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
2063
|
|
|
|
|
|
PL_ptr_table = NULL; |
2064
|
|
|
|
|
|
#endif |
2065
|
|
|
|
|
|
} |
2066
|
|
|
|
|
|
|
2067
|
|
|
|
|
|
MUTEX_UNLOCK(&thread->mutex); |
2068
|
|
|
|
|
|
|
2069
|
|
|
|
|
|
if (! err) { |
2070
|
|
|
|
|
|
XSRETURN_UNDEF; |
2071
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
ST(0) = sv_2mortal(err); |
2074
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
2075
|
|
|
|
|
|
#line 2076 "threads.c" |
2076
|
|
|
|
|
|
} |
2077
|
|
|
|
|
|
XSRETURN(1); |
2078
|
|
|
|
|
|
} |
2079
|
|
|
|
|
|
|
2080
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
2081
|
|
|
|
|
|
#ifdef __cplusplus |
2082
|
|
|
|
|
|
extern "C" |
2083
|
|
|
|
|
|
#endif |
2084
|
|
|
|
|
|
XS_EXTERNAL(boot_threads); /* prototype to pass -Wmissing-prototypes */ |
2085
|
0
|
|
|
|
|
XS_EXTERNAL(boot_threads) |
2086
|
|
|
|
|
|
{ |
2087
|
0
|
|
|
|
|
dVAR; dXSARGS; |
2088
|
|
|
|
|
|
#if (PERL_REVISION == 5 && PERL_VERSION < 9) |
2089
|
|
|
|
|
|
char* file = __FILE__; |
2090
|
|
|
|
|
|
#else |
2091
|
|
|
|
|
|
const char* file = __FILE__; |
2092
|
|
|
|
|
|
#endif |
2093
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
2095
|
|
|
|
|
|
PERL_UNUSED_VAR(items); /* -W */ |
2096
|
|
|
|
|
|
#ifdef XS_APIVERSION_BOOTCHECK |
2097
|
0
|
|
|
|
|
XS_APIVERSION_BOOTCHECK; |
2098
|
|
|
|
|
|
#endif |
2099
|
0
|
|
|
|
|
XS_VERSION_BOOTCHECK; |
2100
|
|
|
|
|
|
|
2101
|
|
|
|
|
|
#if XSubPPtmpAAAA |
2102
|
|
|
|
|
|
newXS("threads::create", XS_threads_create, file); |
2103
|
|
|
|
|
|
newXS("threads::list", XS_threads_list, file); |
2104
|
|
|
|
|
|
newXS("threads::self", XS_threads_self, file); |
2105
|
|
|
|
|
|
newXS("threads::tid", XS_threads_tid, file); |
2106
|
|
|
|
|
|
newXS("threads::join", XS_threads_join, file); |
2107
|
|
|
|
|
|
newXS("threads::yield", XS_threads_yield, file); |
2108
|
|
|
|
|
|
newXS("threads::detach", XS_threads_detach, file); |
2109
|
|
|
|
|
|
newXS("threads::kill", XS_threads_kill, file); |
2110
|
|
|
|
|
|
newXS("threads::DESTROY", XS_threads_DESTROY, file); |
2111
|
|
|
|
|
|
newXS("threads::equal", XS_threads_equal, file); |
2112
|
|
|
|
|
|
newXS("threads::object", XS_threads_object, file); |
2113
|
|
|
|
|
|
newXS("threads::_handle", XS_threads__handle, file); |
2114
|
|
|
|
|
|
newXS("threads::get_stack_size", XS_threads_get_stack_size, file); |
2115
|
|
|
|
|
|
newXS("threads::set_stack_size", XS_threads_set_stack_size, file); |
2116
|
|
|
|
|
|
newXS("threads::is_running", XS_threads_is_running, file); |
2117
|
|
|
|
|
|
newXS("threads::is_detached", XS_threads_is_detached, file); |
2118
|
|
|
|
|
|
newXS("threads::is_joinable", XS_threads_is_joinable, file); |
2119
|
|
|
|
|
|
newXS("threads::wantarray", XS_threads_wantarray, file); |
2120
|
|
|
|
|
|
newXS("threads::set_thread_exit_only", XS_threads_set_thread_exit_only, file); |
2121
|
|
|
|
|
|
newXS("threads::error", XS_threads_error, file); |
2122
|
|
|
|
|
|
#endif |
2123
|
|
|
|
|
|
|
2124
|
|
|
|
|
|
/* Initialisation Section */ |
2125
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
#if XSubPPtmpAAAA |
2127
|
|
|
|
|
|
#endif |
2128
|
|
|
|
|
|
#line 1750 "threads.xs" |
2129
|
|
|
|
|
|
{ |
2130
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2131
|
|
|
|
|
|
SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, |
2132
|
|
|
|
|
|
sizeof(MY_POOL_KEY)-1, TRUE); |
2133
|
|
|
|
|
|
my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1)); |
2134
|
|
|
|
|
|
|
2135
|
|
|
|
|
|
MY_CXT_INIT; |
2136
|
|
|
|
|
|
|
2137
|
|
|
|
|
|
Zero(my_poolp, 1, my_pool_t); |
2138
|
|
|
|
|
|
sv_setuv(my_pool_sv, PTR2UV(my_poolp)); |
2139
|
|
|
|
|
|
|
2140
|
|
|
|
|
|
PL_perl_destruct_level = 2; |
2141
|
|
|
|
|
|
MUTEX_INIT(&MY_POOL.create_destruct_mutex); |
2142
|
|
|
|
|
|
MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
2143
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
PL_threadhook = &Perl_ithread_hook; |
2145
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
MY_POOL.tid_counter = 1; |
2147
|
|
|
|
|
|
# ifdef THREAD_CREATE_NEEDS_STACK |
2148
|
|
|
|
|
|
MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK; |
2149
|
|
|
|
|
|
# endif |
2150
|
|
|
|
|
|
|
2151
|
|
|
|
|
|
/* The 'main' thread is thread 0. |
2152
|
|
|
|
|
|
* It is detached (unjoinable) and immortal. |
2153
|
|
|
|
|
|
*/ |
2154
|
|
|
|
|
|
|
2155
|
|
|
|
|
|
MUTEX_INIT(&MY_POOL.main_thread.mutex); |
2156
|
|
|
|
|
|
|
2157
|
|
|
|
|
|
/* Head of the threads list */ |
2158
|
|
|
|
|
|
MY_POOL.main_thread.next = &MY_POOL.main_thread; |
2159
|
|
|
|
|
|
MY_POOL.main_thread.prev = &MY_POOL.main_thread; |
2160
|
|
|
|
|
|
|
2161
|
|
|
|
|
|
MY_POOL.main_thread.count = 1; /* Immortal */ |
2162
|
|
|
|
|
|
|
2163
|
|
|
|
|
|
MY_POOL.main_thread.interp = aTHX; |
2164
|
|
|
|
|
|
MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */ |
2165
|
|
|
|
|
|
MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size; |
2166
|
|
|
|
|
|
# ifdef WIN32 |
2167
|
|
|
|
|
|
MY_POOL.main_thread.thr = GetCurrentThreadId(); |
2168
|
|
|
|
|
|
# else |
2169
|
|
|
|
|
|
MY_POOL.main_thread.thr = pthread_self(); |
2170
|
|
|
|
|
|
# endif |
2171
|
|
|
|
|
|
|
2172
|
|
|
|
|
|
S_ithread_set(aTHX_ &MY_POOL.main_thread); |
2173
|
|
|
|
|
|
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
2174
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
2175
|
|
|
|
|
|
} |
2176
|
|
|
|
|
|
|
2177
|
|
|
|
|
|
#line 2178 "threads.c" |
2178
|
|
|
|
|
|
|
2179
|
|
|
|
|
|
/* End of Initialisation Section */ |
2180
|
|
|
|
|
|
|
2181
|
|
|
|
|
|
#if (PERL_REVISION == 5 && PERL_VERSION >= 9) |
2182
|
0
|
|
|
|
|
if (PL_unitcheckav) |
2183
|
0
|
|
|
|
|
call_list(PL_scopestack_ix, PL_unitcheckav); |
2184
|
|
|
|
|
|
#endif |
2185
|
0
|
|
|
|
|
XSRETURN_YES; |
2186
|
|
|
|
|
|
} |
2187
|
|
|
|
|
|
|