ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro-Multicore/Multicore.xs
(Generate patch)

Comparing Coro-Multicore/Multicore.xs (file contents):
Revision 1.11 by root, Sun Jul 5 02:52:15 2015 UTC vs.
Revision 1.21 by root, Sun Aug 26 15:30:55 2018 UTC

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
27static pthread_key_t current_key; 36#define RECURSION_CHECK 0
37
38static X_TLS_DECLARE(current_key);
39#if RECURSION_CHECK
40static X_TLS_DECLARE(check_key);
41#endif
42
28 43
29static s_epipe ep; 44static s_epipe ep;
30static void *perl_thx; 45static void *perl_thx;
31static sigset_t cursigset, fullsigset; 46static sigset_t cursigset, fullsigset;
32 47
… …
108X_THREAD_PROC(thread_proc) 123X_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
175static void 190static void
176pmapi_release (void) 191pmapi_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 & 1 : global_enable)) 200 if (! ((thread_enable ? thread_enable : global_enable) & 1))
179 { 201 {
180 pthread_setspecific (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 pthread_setspecific (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
191 X_LOCK (release_m); 213 X_LOCK (release_m);
192 214
193 if (idle <= min_idle) 215 if (idle <= min_idle)
… …
207 229
208static void 230static void
209pmapi_acquire (void) 231pmapi_acquire (void)
210{ 232{
211 int jeret; 233 int jeret;
212 struct tctx *ctx = pthread_getspecific (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
234static void 266static void
235set_thread_enable (pTHX_ void *arg) 267set_thread_enable (pTHX_ void *arg)
236{ 268{
… …
241 273
242PROTOTYPES: DISABLE 274PROTOTYPES: DISABLE
243 275
244BOOT: 276BOOT:
245{ 277{
246 #ifndef _WIN32 278#ifndef _WIN32
247 sigfillset (&fullsigset); 279 sigfillset (&fullsigset);
248 #endif 280#endif
249 281
250 pthread_key_create (&current_key, 0); 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;
… …
259 X_LOCK (release_m); 294 X_LOCK (release_m);
260 while (idle < min_idle) 295 while (idle < min_idle)
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's simple */ 299 /* not perfectly efficient to do it this way, but it is simple */
265 perl_multicore_init (); 300 perl_multicore_init (); /* calls release */
266 perl_multicore_api->pmapi_release = pmapi_release; 301 perl_multicore_api->pmapi_release = pmapi_release;
267 perl_multicore_api->pmapi_acquire = pmapi_acquire; 302 perl_multicore_api->pmapi_acquire = pmapi_acquire;
268} 303}
269 304
270bool 305bool
… …
325 360
326void 361void
327sleep (NV seconds) 362sleep (NV seconds)
328 CODE: 363 CODE:
329 perlinterp_release (); 364 perlinterp_release ();
330 usleep (seconds * 1e6); 365 {
366 int nsec = seconds;
367 if (nsec) sleep (nsec);
368 nsec = (seconds - nsec) * 1e9;
369 if (nsec) usleep (nsec);
370 }
331 perlinterp_acquire (); 371 perlinterp_acquire ();
332 372

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines