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.9 by root, Fri Jul 3 02:35:48 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
… …
37struct tctx 52struct tctx
38{ 53{
39 void *coro; 54 void *coro;
40 int wait_f; 55 int wait_f;
41 xcond_t acquire_c; 56 xcond_t acquire_c;
57 int jeret;
42}; 58};
43 59
44static struct tctx *tctx_free; 60static struct tctx *tctx_free;
45 61
46static struct tctx * 62static struct tctx *
… …
107X_THREAD_PROC(thread_proc) 123X_THREAD_PROC(thread_proc)
108{ 124{
109 PERL_SET_CONTEXT (perl_thx); 125 PERL_SET_CONTEXT (perl_thx);
110 126
111 { 127 {
112 dTHX; /* inefficient, we already have perl_thx, but I see no better way */ 128 dTHXa (perl_thx);
129 dJMPENV;
113 struct tctx *ctx; 130 struct tctx *ctx;
131 int catchret;
114 132
115 X_LOCK (release_m); 133 X_LOCK (release_m);
116 134
117 for (;;) 135 for (;;)
118 { 136 {
… …
134 152
135 if (!ctx) /* timed out? */ 153 if (!ctx) /* timed out? */
136 break; 154 break;
137 155
138 pthread_sigmask (SIG_SETMASK, &cursigset, 0); 156 pthread_sigmask (SIG_SETMASK, &cursigset, 0);
157 JMPENV_PUSH (ctx->jeret);
139 158
159 if (!ctx->jeret)
140 while (ctx->coro) 160 while (ctx->coro)
141 CORO_SCHEDULE; 161 CORO_SCHEDULE;
142 162
163 JMPENV_POP;
143 pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset); 164 pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset);
144 165
145 X_LOCK (acquire_m); 166 X_LOCK (acquire_m);
146 ctx->wait_f = 1; 167 ctx->wait_f = 1;
147 X_COND_SIGNAL (ctx->acquire_c); 168 X_COND_SIGNAL (ctx->acquire_c);
… …
167} 188}
168 189
169static void 190static void
170pmapi_release (void) 191pmapi_release (void)
171{ 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
172 if (!(thread_enable ? thread_enable & 1 : global_enable)) 200 if (! ((thread_enable ? thread_enable : global_enable) & 1))
173 { 201 {
174 pthread_setspecific (current_key, 0); 202 X_TLS_SET (current_key, 0);
175 return; 203 return;
176 } 204 }
177 205
178 struct tctx *ctx = tctx_get (); 206 struct tctx *ctx = tctx_get ();
179 ctx->coro = SvREFCNT_inc_NN (CORO_CURRENT); 207 ctx->coro = SvREFCNT_inc_simple_NN (CORO_CURRENT);
180 ctx->wait_f = 0; 208 ctx->wait_f = 0;
181 209
182 pthread_setspecific (current_key, ctx); 210 X_TLS_SET (current_key, ctx);
183 pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset); 211 pthread_sigmask (SIG_SETMASK, &fullsigset, &cursigset);
184 212
185 X_LOCK (release_m); 213 X_LOCK (release_m);
186 214
187 if (idle <= min_idle) 215 if (idle <= min_idle)
… …
200} 228}
201 229
202static void 230static void
203pmapi_acquire (void) 231pmapi_acquire (void)
204{ 232{
205 struct tctx *ctx = pthread_getspecific (current_key); 233 int jeret;
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
206 242
207 if (!ctx) 243 if (!ctx)
208 return; 244 return;
209 245
210 X_LOCK (acquire_m); 246 X_LOCK (acquire_m);
… …
214 s_epipe_signal (&ep); 250 s_epipe_signal (&ep);
215 while (!ctx->wait_f) 251 while (!ctx->wait_f)
216 X_COND_WAIT (ctx->acquire_c, acquire_m); 252 X_COND_WAIT (ctx->acquire_c, acquire_m);
217 X_UNLOCK (acquire_m); 253 X_UNLOCK (acquire_m);
218 254
255 jeret = ctx->jeret;
219 tctx_put (ctx); 256 tctx_put (ctx);
220 pthread_sigmask (SIG_SETMASK, &cursigset, 0); 257 pthread_sigmask (SIG_SETMASK, &cursigset, 0);
258
259 if (jeret)
260 {
261 dTHX;
262 JMPENV_JUMP (jeret);
263 }
221} 264}
222 265
223static void 266static void
224set_thread_enable (pTHX_ void *arg) 267set_thread_enable (pTHX_ void *arg)
225{ 268{
… …
230 273
231PROTOTYPES: DISABLE 274PROTOTYPES: DISABLE
232 275
233BOOT: 276BOOT:
234{ 277{
235 #ifndef _WIN32 278#ifndef _WIN32
236 sigfillset (&fullsigset); 279 sigfillset (&fullsigset);
237 sigemptyset (&fullsigset);
238 #endif 280#endif
239 281
240 pthread_key_create (&current_key, 0); 282 X_TLS_INIT (current_key);
283#if RECURSION_CHECK
284 X_TLS_INIT (check_key);
285#endif
241 286
242 if (s_epipe_new (&ep)) 287 if (s_epipe_new (&ep))
243 croak ("Coro::Multicore: unable to initialise event pipe.\n"); 288 croak ("Coro::Multicore: unable to initialise event pipe.\n");
244 289
245 perl_thx = PERL_GET_CONTEXT; 290 perl_thx = PERL_GET_CONTEXT;
… …
249 X_LOCK (release_m); 294 X_LOCK (release_m);
250 while (idle < min_idle) 295 while (idle < min_idle)
251 start_thread (); 296 start_thread ();
252 X_UNLOCK (release_m); 297 X_UNLOCK (release_m);
253 298
254 /* 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 */
255 perl_multicore_init (); 300 perl_multicore_init (); /* calls release */
256 perl_multicore_api->pmapi_release = pmapi_release; 301 perl_multicore_api->pmapi_release = pmapi_release;
257 perl_multicore_api->pmapi_acquire = pmapi_acquire; 302 perl_multicore_api->pmapi_acquire = pmapi_acquire;
258} 303}
259 304
260bool 305bool
… …
315 360
316void 361void
317sleep (NV seconds) 362sleep (NV seconds)
318 CODE: 363 CODE:
319 perlinterp_release (); 364 perlinterp_release ();
320 usleep (seconds * 1e6); 365 {
366 int nsec = seconds;
367 if (nsec) sleep (nsec);
368 nsec = (seconds - nsec) * 1e9;
369 if (nsec) usleep (nsec);
370 }
321 perlinterp_acquire (); 371 perlinterp_acquire ();
322 372

Diff Legend

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