|
|
1 | /* most win32 perls are beyond fixing, requiring dTHX */ |
|
|
2 | /* even for ISO-C functions such as malloc. avoid! avoid! avoid! */ |
|
|
3 | /* and fail to define numerous symbols, but still overrwide them */ |
|
|
4 | /* with non-working versions (e.g. setjmp). */ |
|
|
5 | #ifdef _WIN32 |
|
|
6 | /*# define PERL_CORE 1 fixes some, breaks others */ |
|
|
7 | #else |
1 | #define PERL_NO_GET_CONTEXT |
8 | # define PERL_NO_GET_CONTEXT |
|
|
9 | #endif |
2 | |
10 | |
3 | #include "EXTERN.h" |
11 | #include "EXTERN.h" |
4 | #include "perl.h" |
12 | #include "perl.h" |
5 | #include "XSUB.h" |
13 | #include "XSUB.h" |
6 | |
14 | |
… | |
… | |
10 | #include "perlmulticore.h" |
18 | #include "perlmulticore.h" |
11 | #include "schmorp.h" |
19 | #include "schmorp.h" |
12 | #include "xthread.h" |
20 | #include "xthread.h" |
13 | |
21 | |
14 | #ifdef _WIN32 |
22 | #ifdef _WIN32 |
15 | typedef char sigset_t; |
23 | #ifndef sigset_t |
16 | #define pthread_sigmask(mode,new,old) |
24 | #define sigset_t int |
|
|
25 | #endif |
17 | #endif |
26 | #endif |
18 | |
27 | |
19 | #ifndef SvREFCNT_dec_NN |
28 | #ifndef SvREFCNT_dec_NN |
20 | #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv) |
29 | #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv) |
21 | #endif |
30 | #endif |
22 | |
31 | |
23 | #ifndef SvREFCNT_inc_NN |
32 | #ifndef SvREFCNT_inc_NN |
24 | #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv) |
33 | #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv) |
25 | #endif |
34 | #endif |
26 | |
35 | |
|
|
36 | #define RECURSION_CHECK 0 |
|
|
37 | |
27 | static X_TLS_DECLARE(current_key); |
38 | static X_TLS_DECLARE(current_key); |
|
|
39 | #if RECURSION_CHECK |
|
|
40 | static X_TLS_DECLARE(check_key); |
|
|
41 | #endif |
|
|
42 | |
28 | |
43 | |
29 | static s_epipe ep; |
44 | static s_epipe ep; |
30 | static void *perl_thx; |
45 | static void *perl_thx; |
31 | static sigset_t cursigset, fullsigset; |
46 | static sigset_t cursigset, fullsigset; |
32 | |
47 | |
… | |
… | |
108 | X_THREAD_PROC(thread_proc) |
123 | X_THREAD_PROC(thread_proc) |
109 | { |
124 | { |
110 | PERL_SET_CONTEXT (perl_thx); |
125 | PERL_SET_CONTEXT (perl_thx); |
111 | |
126 | |
112 | { |
127 | { |
113 | dTHX; /* inefficient, we already have perl_thx, but I see no better way */ |
128 | dTHXa (perl_thx); |
114 | dJMPENV; |
129 | dJMPENV; |
115 | struct tctx *ctx; |
130 | struct tctx *ctx; |
116 | int catchret; |
131 | int catchret; |
117 | |
132 | |
118 | X_LOCK (release_m); |
133 | X_LOCK (release_m); |
… | |
… | |
173 | } |
188 | } |
174 | |
189 | |
175 | static void |
190 | static void |
176 | pmapi_release (void) |
191 | pmapi_release (void) |
177 | { |
192 | { |
|
|
193 | #if RECURSION_CHECK |
|
|
194 | if (X_TLS_GET (check_key)) |
|
|
195 | croak ("perlinterp_release () called without valid perl context"); |
|
|
196 | |
|
|
197 | X_TLS_SET (check_key, &check_key); |
|
|
198 | #endif |
|
|
199 | |
178 | if (! ((thread_enable ? thread_enable : global_enable) & 1)) |
200 | if (! ((thread_enable ? thread_enable : global_enable) & 1)) |
179 | { |
201 | { |
180 | X_TLS_SET (current_key, 0); |
202 | X_TLS_SET (current_key, 0); |
181 | return; |
203 | return; |
182 | } |
204 | } |
183 | |
205 | |
184 | struct tctx *ctx = tctx_get (); |
206 | struct tctx *ctx = tctx_get (); |
185 | ctx->coro = SvREFCNT_inc_NN (CORO_CURRENT); |
207 | ctx->coro = SvREFCNT_inc_simple_NN (CORO_CURRENT); |
186 | ctx->wait_f = 0; |
208 | ctx->wait_f = 0; |
187 | |
209 | |
188 | X_TLS_SET (current_key, ctx); |
210 | X_TLS_SET (current_key, ctx); |
189 | pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset); |
211 | pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset); |
190 | |
212 | |
… | |
… | |
208 | static void |
230 | static void |
209 | pmapi_acquire (void) |
231 | pmapi_acquire (void) |
210 | { |
232 | { |
211 | int jeret; |
233 | int jeret; |
212 | struct tctx *ctx = X_TLS_GET (current_key); |
234 | struct tctx *ctx = X_TLS_GET (current_key); |
|
|
235 | |
|
|
236 | #if RECURSION_CHECK |
|
|
237 | if (X_TLS_GET (check_key) != &check_key) |
|
|
238 | croak ("perlinterp_acquire () called with valid perl context"); |
|
|
239 | |
|
|
240 | X_TLS_SET (check_key, 0); |
|
|
241 | #endif |
213 | |
242 | |
214 | if (!ctx) |
243 | if (!ctx) |
215 | return; |
244 | return; |
216 | |
245 | |
217 | X_LOCK (acquire_m); |
246 | X_LOCK (acquire_m); |
… | |
… | |
226 | jeret = ctx->jeret; |
255 | jeret = ctx->jeret; |
227 | tctx_put (ctx); |
256 | tctx_put (ctx); |
228 | pthread_sigmask (SIG_SETMASK, &cursigset, 0); |
257 | pthread_sigmask (SIG_SETMASK, &cursigset, 0); |
229 | |
258 | |
230 | if (jeret) |
259 | if (jeret) |
|
|
260 | { |
|
|
261 | dTHX; |
231 | JMPENV_JUMP (jeret); |
262 | JMPENV_JUMP (jeret); |
|
|
263 | } |
232 | } |
264 | } |
233 | |
265 | |
234 | static void |
266 | static void |
235 | set_thread_enable (pTHX_ void *arg) |
267 | set_thread_enable (pTHX_ void *arg) |
236 | { |
268 | { |
… | |
… | |
241 | |
273 | |
242 | PROTOTYPES: DISABLE |
274 | PROTOTYPES: DISABLE |
243 | |
275 | |
244 | BOOT: |
276 | BOOT: |
245 | { |
277 | { |
246 | #ifndef _WIN32 |
278 | #ifndef _WIN32 |
247 | sigfillset (&fullsigset); |
279 | sigfillset (&fullsigset); |
248 | #endif |
280 | #endif |
249 | |
281 | |
250 | X_TLS_INIT (current_key); |
282 | X_TLS_INIT (current_key); |
|
|
283 | #if RECURSION_CHECK |
|
|
284 | X_TLS_INIT (check_key); |
|
|
285 | #endif |
251 | |
286 | |
252 | if (s_epipe_new (&ep)) |
287 | if (s_epipe_new (&ep)) |
253 | croak ("Coro::Multicore: unable to initialise event pipe.\n"); |
288 | croak ("Coro::Multicore: unable to initialise event pipe.\n"); |
254 | |
289 | |
255 | perl_thx = PERL_GET_CONTEXT; |
290 | perl_thx = PERL_GET_CONTEXT; |
… | |
… | |
261 | start_thread (); |
296 | start_thread (); |
262 | X_UNLOCK (release_m); |
297 | X_UNLOCK (release_m); |
263 | |
298 | |
264 | /* not perfectly efficient to do it this way, but it is simple */ |
299 | /* not perfectly efficient to do it this way, but it is simple */ |
265 | perl_multicore_init (); /* calls release */ |
300 | perl_multicore_init (); /* calls release */ |
266 | perl_multicore_acquire (); |
|
|
267 | perl_multicore_api->pmapi_release = pmapi_release; |
301 | perl_multicore_api->pmapi_release = pmapi_release; |
268 | perl_multicore_api->pmapi_acquire = pmapi_acquire; |
302 | perl_multicore_api->pmapi_acquire = pmapi_acquire; |
269 | } |
303 | } |
270 | |
304 | |
271 | bool |
305 | bool |
… | |
… | |
326 | |
360 | |
327 | void |
361 | void |
328 | sleep (NV seconds) |
362 | sleep (NV seconds) |
329 | CODE: |
363 | CODE: |
330 | perlinterp_release (); |
364 | perlinterp_release (); |
331 | usleep (seconds * 1e6); |
365 | { |
|
|
366 | int nsec = seconds; |
|
|
367 | if (nsec) sleep (nsec); |
|
|
368 | nsec = (seconds - nsec) * 1e9; |
|
|
369 | if (nsec) usleep (nsec); |
|
|
370 | } |
332 | perlinterp_acquire (); |
371 | perlinterp_acquire (); |
333 | |
372 | |