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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.98 by root, Sun Nov 26 21:25:53 2006 UTC vs.
Revision 1.127 by root, Tue Dec 12 13:56:45 2006 UTC

… …
4#include "perl.h" 4#include "perl.h"
5#include "XSUB.h" 5#include "XSUB.h"
6 6
7#include "patchlevel.h" 7#include "patchlevel.h"
8 8
9#if PERL_VERSION < 6 9#include <stdio.h>
10#include <errno.h>
11#include <assert.h>
12
13#ifdef HAVE_MMAP
14# include <unistd.h>
15# include <sys/mman.h>
16# ifndef MAP_ANONYMOUS
17# ifdef MAP_ANON
18# define MAP_ANONYMOUS MAP_ANON
19# else
20# undef HAVE_MMAP
21# endif
22# endif
23# include <limits.h>
24# ifndef PAGESIZE
25# define PAGESIZE pagesize
26# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
27static long pagesize;
28# else
29# define BOOT_PAGESIZE (void)0
30# endif
31#else
32# define PAGESIZE 0
33# define BOOT_PAGESIZE (void)0
34#endif
35
36#if USE_VALGRIND
37# include <valgrind/valgrind.h>
38#endif
39
40/* the maximum number of idle cctx that will be pooled */
41#define MAX_IDLE_CCTX 8
42
43#define PERL_VERSION_ATLEAST(a,b,c) \
44 (PERL_REVISION > (a) \
45 || (PERL_REVISION == (a) \
46 && (PERL_VERSION > (b) \
47 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
48
49#if !PERL_VERSION_ATLEAST (5,6,0)
10# ifndef PL_ppaddr 50# ifndef PL_ppaddr
11# define PL_ppaddr ppaddr 51# define PL_ppaddr ppaddr
12# endif 52# endif
13# ifndef call_sv 53# ifndef call_sv
14# define call_sv perl_call_sv 54# define call_sv perl_call_sv
… …
25# ifndef IS_PADCONST 65# ifndef IS_PADCONST
26# define IS_PADCONST(v) 0 66# define IS_PADCONST(v) 0
27# endif 67# endif
28#endif 68#endif
29 69
30#include <stdio.h> 70/* 5.8.7 */
31#include <errno.h> 71#ifndef SvRV_set
72# define SvRV_set(s,v) SvRV(s) = (v)
73#endif
32 74
33#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64 75#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
34# undef STACKGUARD 76# undef STACKGUARD
35#endif 77#endif
36 78
37#ifndef STACKGUARD 79#ifndef STACKGUARD
38# define STACKGUARD 0 80# define STACKGUARD 0
39#endif 81#endif
40 82
41#ifdef HAVE_MMAP 83/* prefer perl internal functions over our own? */
42# include <unistd.h> 84#ifndef PREFER_PERL_FUNCTIONS
43# include <sys/mman.h> 85# define PREFER_PERL_FUNCTIONS 0
44# ifndef MAP_ANONYMOUS
45# ifdef MAP_ANON
46# define MAP_ANONYMOUS MAP_ANON
47# else
48# undef HAVE_MMAP
49# endif
50# endif
51# include <limits.h>
52# ifndef PAGESIZE
53# define PAGESIZE pagesize
54# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
55static long pagesize;
56# else
57# define BOOT_PAGESIZE
58# endif
59#endif 86#endif
60 87
61/* The next macro should declare a variable stacklevel that contains and approximation 88/* The next macro should declare a variable stacklevel that contains and approximation
62 * to the current C stack pointer. Its property is that it changes with each call 89 * to the current C stack pointer. Its property is that it changes with each call
63 * and should be unique. */ 90 * and should be unique. */
64#define dSTACKLEVEL int stacklevel 91#define dSTACKLEVEL int stacklevel
65#define STACKLEVEL ((void *)&stacklevel) 92#define STACKLEVEL ((void *)&stacklevel)
66 93
67#define IN_DESTRUCT (PL_main_cv == Nullcv) 94#define IN_DESTRUCT (PL_main_cv == Nullcv)
68 95
96#if __GNUC__ >= 3
97# define attribute(x) __attribute__(x)
98#else
99# define attribute(x)
100#endif
101
102#define NOINLINE attribute ((noinline))
103
69#include "CoroAPI.h" 104#include "CoroAPI.h"
70
71#define TRANSFER_SET_STACKLEVEL 0x8bfbfbfb /* magic cookie */
72 105
73#ifdef USE_ITHREADS 106#ifdef USE_ITHREADS
74static perl_mutex coro_mutex; 107static perl_mutex coro_mutex;
75# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0) 108# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
76# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0) 109# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
77#else 110#else
78# define LOCK (void)0 111# define LOCK (void)0
79# define UNLOCK (void)0 112# define UNLOCK (void)0
80#endif 113#endif
81 114
115struct io_state
116{
117 int errorno;
118 I32 laststype;
119 int laststatval;
120 Stat_t statcache;
121};
122
82static struct CoroAPI coroapi; 123static struct CoroAPI coroapi;
83static AV *main_mainstack; /* used to differentiate between $main and others */ 124static AV *main_mainstack; /* used to differentiate between $main and others */
84static HV *coro_state_stash, *coro_stash; 125static HV *coro_state_stash, *coro_stash;
85static SV *coro_mortal; /* will be freed after next transfer */ 126static SV *coro_mortal; /* will be freed after next transfer */
86 127
128static struct coro_cctx *cctx_first;
129static int cctx_count, cctx_idle;
130
87/* this is a structure representing a c-level coroutine */ 131/* this is a structure representing a c-level coroutine */
88typedef struct coro_stack { 132typedef struct coro_cctx {
89 struct coro_stack *next; 133 struct coro_cctx *next;
90 134
91 /* the stack */ 135 /* the stack */
92 void *sptr; 136 void *sptr;
93 long ssize; /* positive == mmap, otherwise malloc */ 137 long ssize; /* positive == mmap, otherwise malloc */
94 138
95 /* cpu state */ 139 /* cpu state */
96 void *idle_sp; /* sp of top-level transfer/schedule/cede call */ 140 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
97 JMPENV *top_env; 141 JMPENV *top_env;
98 coro_context cctx; 142 coro_context cctx;
99} coro_stack; 143
144 int inuse;
145
146#if USE_VALGRIND
147 int valgrind_id;
148#endif
149} coro_cctx;
150
151enum {
152 CF_RUNNING = 0x0001, /* coroutine is running */
153 CF_READY = 0x0002, /* coroutine is ready */
154 CF_NEW = 0x0004, /* ahs never been switched to */
155};
100 156
101/* this is a structure representing a perl-level coroutine */ 157/* this is a structure representing a perl-level coroutine */
102struct coro { 158struct coro {
103 /* the c coroutine allocated to this perl coroutine, if any */ 159 /* the c coroutine allocated to this perl coroutine, if any */
104 coro_stack *stack; 160 coro_cctx *cctx;
105 161
106 /* data associated with this coroutine (initial args) */ 162 /* data associated with this coroutine (initial args) */
107 AV *args; 163 AV *args;
108 int refcnt; 164 int refcnt;
165 int save; /* CORO_SAVE flags */
166 int flags; /* CF_ flags */
109 167
110 /* optionally saved, might be zero */ 168 /* optionally saved, might be zero */
111 AV *defav; 169 AV *defav; /* @_ */
112 SV *defsv; 170 SV *defsv; /* $_ */
113 SV *errsv; 171 SV *errsv; /* $@ */
172 SV *irssv; /* $/ */
173 SV *irssv_sv; /* real $/ cache */
114 174
115 /* saved global state not related to stacks */ 175#define VAR(name,type) type name;
116 U8 dowarn; 176# include "state.h"
117 I32 in_eval; 177#undef VAR
118
119 /* the stacks and related info (callchain etc..) */
120 PERL_SI *curstackinfo;
121 AV *curstack;
122 AV *mainstack;
123 SV **stack_sp;
124 OP *op;
125 SV **curpad;
126 AV *comppad;
127 CV *compcv;
128 SV **stack_base;
129 SV **stack_max;
130 SV **tmps_stack;
131 I32 tmps_floor;
132 I32 tmps_ix;
133 I32 tmps_max;
134 I32 *markstack;
135 I32 *markstack_ptr;
136 I32 *markstack_max;
137 I32 *scopestack;
138 I32 scopestack_ix;
139 I32 scopestack_max;
140 ANY *savestack;
141 I32 savestack_ix;
142 I32 savestack_max;
143 OP **retstack;
144 I32 retstack_ix;
145 I32 retstack_max;
146 PMOP *curpm;
147 COP *curcop;
148 178
149 /* coro process data */ 179 /* coro process data */
150 int prio; 180 int prio;
151}; 181};
152 182
… …
159 AV *padlist = CvPADLIST (cv); 189 AV *padlist = CvPADLIST (cv);
160 AV *newpadlist, *newpad; 190 AV *newpadlist, *newpad;
161 191
162 newpadlist = newAV (); 192 newpadlist = newAV ();
163 AvREAL_off (newpadlist); 193 AvREAL_off (newpadlist);
164#if PERL_VERSION < 9 194#if PERL_VERSION_ATLEAST (5,9,0)
195 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
196#else
165 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1); 197 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
166#else
167 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
168#endif 198#endif
169 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)]; 199 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
170 --AvFILLp (padlist); 200 --AvFILLp (padlist);
171 201
172 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE))); 202 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
… …
216 246
217#define PERL_MAGIC_coro PERL_MAGIC_ext 247#define PERL_MAGIC_coro PERL_MAGIC_ext
218 248
219static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free}; 249static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
220 250
251#define CORO_MAGIC(cv) \
252 SvMAGIC (cv) \
253 ? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
254 ? SvMAGIC (cv) \
255 : mg_find ((SV *)cv, PERL_MAGIC_coro) \
256 : 0
257
221/* the next two functions merely cache the padlists */ 258/* the next two functions merely cache the padlists */
222static void 259static void
223get_padlist (CV *cv) 260get_padlist (CV *cv)
224{ 261{
225 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); 262 MAGIC *mg = CORO_MAGIC (cv);
263 AV *av;
226 264
227 if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0) 265 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
228 CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj); 266 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
229 else 267 else
230 { 268 {
231#if 0 269#if PREFER_PERL_FUNCTIONS
232 /* this is probably cleaner, but also slower? */ 270 /* this is probably cleaner, but also slower? */
233 CV *cp = Perl_cv_clone (cv); 271 CV *cp = Perl_cv_clone (cv);
234 CvPADLIST (cv) = CvPADLIST (cp); 272 CvPADLIST (cv) = CvPADLIST (cp);
235 CvPADLIST (cp) = 0; 273 CvPADLIST (cp) = 0;
236 SvREFCNT_dec (cp); 274 SvREFCNT_dec (cp);
… …
241} 279}
242 280
243static void 281static void
244put_padlist (CV *cv) 282put_padlist (CV *cv)
245{ 283{
246 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); 284 MAGIC *mg = CORO_MAGIC (cv);
285 AV *av;
247 286
248 if (!mg) 287 if (!mg)
249 { 288 {
250 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0); 289 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
251 mg = mg_find ((SV *)cv, PERL_MAGIC_coro); 290 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
252 mg->mg_virtual = &vtbl_coro; 291 mg->mg_virtual = &vtbl_coro;
253 mg->mg_obj = (SV *)newAV (); 292 mg->mg_obj = (SV *)newAV ();
254 } 293 }
255 294
256 av_push ((AV *)mg->mg_obj, (SV *)CvPADLIST (cv)); 295 av = (AV *)mg->mg_obj;
296
297 if (AvFILLp (av) >= AvMAX (av))
298 av_extend (av, AvMAX (av) + 1);
299
300 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
257} 301}
258 302
259#define SB do { 303#define SB do {
260#define SE } while (0) 304#define SE } while (0)
261 305
262#define LOAD(state) load_state((state));
263#define SAVE(state,flags) save_state((state),(flags));
264
265#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE 306#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
266 307
267static void 308static void
268load_state(Coro__State c) 309load_perl (Coro__State c)
269{ 310{
270 PL_dowarn = c->dowarn; 311#define VAR(name,type) PL_ ## name = c->name;
271 PL_in_eval = c->in_eval; 312# include "state.h"
272 313#undef VAR
273 PL_curstackinfo = c->curstackinfo;
274 PL_curstack = c->curstack;
275 PL_mainstack = c->mainstack;
276 PL_stack_sp = c->stack_sp;
277 PL_op = c->op;
278 PL_curpad = c->curpad;
279 PL_comppad = c->comppad;
280 PL_compcv = c->compcv;
281 PL_stack_base = c->stack_base;
282 PL_stack_max = c->stack_max;
283 PL_tmps_stack = c->tmps_stack;
284 PL_tmps_floor = c->tmps_floor;
285 PL_tmps_ix = c->tmps_ix;
286 PL_tmps_max = c->tmps_max;
287 PL_markstack = c->markstack;
288 PL_markstack_ptr = c->markstack_ptr;
289 PL_markstack_max = c->markstack_max;
290 PL_scopestack = c->scopestack;
291 PL_scopestack_ix = c->scopestack_ix;
292 PL_scopestack_max = c->scopestack_max;
293 PL_savestack = c->savestack;
294 PL_savestack_ix = c->savestack_ix;
295 PL_savestack_max = c->savestack_max;
296#if PERL_VERSION < 9
297 PL_retstack = c->retstack;
298 PL_retstack_ix = c->retstack_ix;
299 PL_retstack_max = c->retstack_max;
300#endif
301 PL_curpm = c->curpm;
302 PL_curcop = c->curcop;
303 314
304 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav); 315 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
305 if (c->defsv) REPLACE_SV (DEFSV , c->defsv); 316 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
306 if (c->errsv) REPLACE_SV (ERRSV , c->errsv); 317 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
318 if (c->irssv)
319 {
320 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
321 SvREFCNT_dec (c->irssv);
322 else
323 {
324 REPLACE_SV (PL_rs, c->irssv);
325 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
326 sv_setsv (c->irssv_sv, PL_rs);
327 }
328 }
307 329
308 { 330 {
309 dSP; 331 dSP;
310 CV *cv; 332 CV *cv;
311 333
312 /* now do the ugly restore mess */ 334 /* now do the ugly restore mess */
313 while ((cv = (CV *)POPs)) 335 while ((cv = (CV *)POPs))
314 { 336 {
315 AV *padlist = (AV *)POPs;
316
317 if (padlist)
318 {
319 put_padlist (cv); /* mark this padlist as available */ 337 put_padlist (cv); /* mark this padlist as available */
320 CvPADLIST(cv) = padlist; 338 CvDEPTH (cv) = PTR2IV (POPs);
321 } 339 CvPADLIST (cv) = (AV *)POPs;
322
323 ++CvDEPTH(cv);
324 } 340 }
325 341
326 PUTBACK; 342 PUTBACK;
327 } 343 }
328} 344}
329 345
330static void 346static void
331save_state(Coro__State c, int flags) 347save_perl (Coro__State c)
332{ 348{
333 { 349 {
334 dSP; 350 dSP;
335 I32 cxix = cxstack_ix; 351 I32 cxix = cxstack_ix;
336 PERL_CONTEXT *ccstk = cxstack; 352 PERL_CONTEXT *ccstk = cxstack;
… …
339 /* 355 /*
340 * the worst thing you can imagine happens first - we have to save 356 * the worst thing you can imagine happens first - we have to save
341 * (and reinitialize) all cv's in the whole callchain :( 357 * (and reinitialize) all cv's in the whole callchain :(
342 */ 358 */
343 359
360 EXTEND (SP, 3 + 1);
344 PUSHs (Nullsv); 361 PUSHs (Nullsv);
345 /* this loop was inspired by pp_caller */ 362 /* this loop was inspired by pp_caller */
346 for (;;) 363 for (;;)
347 { 364 {
348 while (cxix >= 0) 365 while (cxix >= 0)
349 { 366 {
350 PERL_CONTEXT *cx = &ccstk[cxix--]; 367 PERL_CONTEXT *cx = &ccstk[cxix--];
351 368
352 if (CxTYPE(cx) == CXt_SUB) 369 if (CxTYPE (cx) == CXt_SUB)
353 { 370 {
354 CV *cv = cx->blk_sub.cv; 371 CV *cv = cx->blk_sub.cv;
372
355 if (CvDEPTH(cv)) 373 if (CvDEPTH (cv))
356 { 374 {
357 EXTEND (SP, CvDEPTH(cv)*2); 375 EXTEND (SP, 3);
358
359 while (--CvDEPTH(cv))
360 {
361 /* this tells the restore code to increment CvDEPTH */
362 PUSHs (Nullsv);
363 PUSHs ((SV *)cv);
364 }
365
366 PUSHs ((SV *)CvPADLIST(cv)); 376 PUSHs ((SV *)CvPADLIST (cv));
377 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
367 PUSHs ((SV *)cv); 378 PUSHs ((SV *)cv);
368 379
380 CvDEPTH (cv) = 0;
369 get_padlist (cv); 381 get_padlist (cv);
370 } 382 }
371 } 383 }
372#ifdef CXt_FORMAT
373 else if (CxTYPE(cx) == CXt_FORMAT)
374 {
375 /* I never used formats, so how should I know how these are implemented? */
376 /* my bold guess is as a simple, plain sub... */
377 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
378 }
379#endif
380 } 384 }
381 385
382 if (top_si->si_type == PERLSI_MAIN) 386 if (top_si->si_type == PERLSI_MAIN)
383 break; 387 break;
384 388
… …
388 } 392 }
389 393
390 PUTBACK; 394 PUTBACK;
391 } 395 }
392 396
393 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0; 397 c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
394 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0; 398 c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
395 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0; 399 c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
400 c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
396 401
397 c->dowarn = PL_dowarn; 402#define VAR(name,type)c->name = PL_ ## name;
398 c->in_eval = PL_in_eval; 403# include "state.h"
399 404#undef VAR
400 c->curstackinfo = PL_curstackinfo;
401 c->curstack = PL_curstack;
402 c->mainstack = PL_mainstack;
403 c->stack_sp = PL_stack_sp;
404 c->op = PL_op;
405 c->curpad = PL_curpad;
406 c->comppad = PL_comppad;
407 c->compcv = PL_compcv;
408 c->stack_base = PL_stack_base;
409 c->stack_max = PL_stack_max;
410 c->tmps_stack = PL_tmps_stack;
411 c->tmps_floor = PL_tmps_floor;
412 c->tmps_ix = PL_tmps_ix;
413 c->tmps_max = PL_tmps_max;
414 c->markstack = PL_markstack;
415 c->markstack_ptr = PL_markstack_ptr;
416 c->markstack_max = PL_markstack_max;
417 c->scopestack = PL_scopestack;
418 c->scopestack_ix = PL_scopestack_ix;
419 c->scopestack_max = PL_scopestack_max;
420 c->savestack = PL_savestack;
421 c->savestack_ix = PL_savestack_ix;
422 c->savestack_max = PL_savestack_max;
423#if PERL_VERSION < 9
424 c->retstack = PL_retstack;
425 c->retstack_ix = PL_retstack_ix;
426 c->retstack_max = PL_retstack_max;
427#endif
428 c->curpm = PL_curpm;
429 c->curcop = PL_curcop;
430} 405}
431 406
432/* 407/*
433 * allocate various perl stacks. This is an exact copy 408 * allocate various perl stacks. This is an exact copy
434 * of perl.c:init_stacks, except that it uses less memory 409 * of perl.c:init_stacks, except that it uses less memory
435 * on the (sometimes correct) assumption that coroutines do 410 * on the (sometimes correct) assumption that coroutines do
436 * not usually need a lot of stackspace. 411 * not usually need a lot of stackspace.
437 */ 412 */
413#if PREFER_PERL_FUNCTIONS
414# define coro_init_stacks init_stacks
415#else
438static void 416static void
439coro_init_stacks () 417coro_init_stacks ()
440{ 418{
441 LOCK;
442
443 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1); 419 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
444 PL_curstackinfo->si_type = PERLSI_MAIN; 420 PL_curstackinfo->si_type = PERLSI_MAIN;
445 PL_curstack = PL_curstackinfo->si_stack; 421 PL_curstack = PL_curstackinfo->si_stack;
446 PL_mainstack = PL_curstack; /* remember in case we switch stacks */ 422 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
447 423
448 PL_stack_base = AvARRAY(PL_curstack); 424 PL_stack_base = AvARRAY(PL_curstack);
449 PL_stack_sp = PL_stack_base; 425 PL_stack_sp = PL_stack_base;
450 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 426 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
451 427
452 New(50,PL_tmps_stack,96,SV*); 428 New(50,PL_tmps_stack,128,SV*);
453 PL_tmps_floor = -1; 429 PL_tmps_floor = -1;
454 PL_tmps_ix = -1; 430 PL_tmps_ix = -1;
455 PL_tmps_max = 96; 431 PL_tmps_max = 128;
456 432
457 New(54,PL_markstack,16,I32); 433 New(54,PL_markstack,32,I32);
458 PL_markstack_ptr = PL_markstack; 434 PL_markstack_ptr = PL_markstack;
459 PL_markstack_max = PL_markstack + 16; 435 PL_markstack_max = PL_markstack + 32;
460 436
461#ifdef SET_MARK_OFFSET 437#ifdef SET_MARK_OFFSET
462 SET_MARK_OFFSET; 438 SET_MARK_OFFSET;
463#endif 439#endif
464 440
465 New(54,PL_scopestack,16,I32); 441 New(54,PL_scopestack,32,I32);
466 PL_scopestack_ix = 0; 442 PL_scopestack_ix = 0;
467 PL_scopestack_max = 16; 443 PL_scopestack_max = 32;
468 444
469 New(54,PL_savestack,96,ANY); 445 New(54,PL_savestack,64,ANY);
470 PL_savestack_ix = 0; 446 PL_savestack_ix = 0;
471 PL_savestack_max = 96; 447 PL_savestack_max = 64;
472 448
473#if PERL_VERSION < 9 449#if !PERL_VERSION_ATLEAST (5,9,0)
474 New(54,PL_retstack,8,OP*); 450 New(54,PL_retstack,16,OP*);
475 PL_retstack_ix = 0; 451 PL_retstack_ix = 0;
476 PL_retstack_max = 8; 452 PL_retstack_max = 16;
477#endif 453#endif
478
479 UNLOCK;
480} 454}
455#endif
481 456
482/* 457/*
483 * destroy the stacks, the callchain etc... 458 * destroy the stacks, the callchain etc...
484 */ 459 */
485static void 460static void
486destroy_stacks() 461coro_destroy_stacks ()
487{ 462{
488 if (!IN_DESTRUCT) 463 if (!IN_DESTRUCT)
489 { 464 {
490 /* is this ugly, I ask? */ 465 /* restore all saved variables and stuff */
491 LEAVE_SCOPE (0); 466 LEAVE_SCOPE (0);
467 assert (PL_tmps_floor == -1);
492 468
493 /* sure it is, but more important: is it correct?? :/ */ 469 /* free all temporaries */
494 FREETMPS; 470 FREETMPS;
471 assert (PL_tmps_ix == -1);
495 472
496 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/ 473 POPSTACK_TO (PL_mainstack);
497 } 474 }
498 475
499 while (PL_curstackinfo->si_next) 476 while (PL_curstackinfo->si_next)
500 PL_curstackinfo = PL_curstackinfo->si_next; 477 PL_curstackinfo = PL_curstackinfo->si_next;
501 478
502 while (PL_curstackinfo) 479 while (PL_curstackinfo)
503 { 480 {
504 PERL_SI *p = PL_curstackinfo->si_prev; 481 PERL_SI *p = PL_curstackinfo->si_prev;
505 482
506 { /*D*//*remove*/
507 dSP;
508 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
509 PUTBACK; /* possibly superfluous */
510 }
511
512 if (!IN_DESTRUCT) 483 if (!IN_DESTRUCT)
513 {
514 dounwind (-1);/*D*//*remove*/
515 SvREFCNT_dec (PL_curstackinfo->si_stack); 484 SvREFCNT_dec (PL_curstackinfo->si_stack);
516 }
517 485
518 Safefree (PL_curstackinfo->si_cxstack); 486 Safefree (PL_curstackinfo->si_cxstack);
519 Safefree (PL_curstackinfo); 487 Safefree (PL_curstackinfo);
520 PL_curstackinfo = p; 488 PL_curstackinfo = p;
521 } 489 }
522 490
523 Safefree (PL_tmps_stack); 491 Safefree (PL_tmps_stack);
524 Safefree (PL_markstack); 492 Safefree (PL_markstack);
525 Safefree (PL_scopestack); 493 Safefree (PL_scopestack);
526 Safefree (PL_savestack); 494 Safefree (PL_savestack);
527#if PERL_VERSION < 9 495#if !PERL_VERSION_ATLEAST (5,9,0)
528 Safefree (PL_retstack); 496 Safefree (PL_retstack);
529#endif 497#endif
530} 498}
531 499
532static void 500static void
533setup_coro (struct coro *coro) 501setup_coro (struct coro *coro)
534{ 502{
535 /* 503 /*
536 * emulate part of the perl startup here. 504 * emulate part of the perl startup here.
537 */ 505 */
538 dTHX;
539 dSP;
540 UNOP myop;
541 SV *sub_init = (SV *)get_cv ("Coro::State::coro_init", FALSE);
542 506
543 coro_init_stacks (); 507 coro_init_stacks ();
544 /*PL_curcop = 0;*/ 508
545 /*PL_in_eval = PL_in_eval;*/ /* inherit */ 509 PL_curcop = &PL_compiling;
510 PL_in_eval = EVAL_NULL;
511 PL_curpm = 0;
512 PL_localizing = 0;
513 PL_dirty = 0;
514 PL_restartop = 0;
515
516 {
517 dSP;
518 LOGOP myop;
519
546 SvREFCNT_dec (GvAV (PL_defgv)); 520 SvREFCNT_dec (GvAV (PL_defgv));
547 GvAV (PL_defgv) = coro->args; coro->args = 0; 521 GvAV (PL_defgv) = coro->args; coro->args = 0;
548 522
549 SPAGAIN;
550
551 Zero (&myop, 1, UNOP); 523 Zero (&myop, 1, LOGOP);
552 myop.op_next = Nullop; 524 myop.op_next = Nullop;
553 myop.op_flags = OPf_WANT_VOID; 525 myop.op_flags = OPf_WANT_VOID;
554 526
527 PUSHMARK (SP);
528 XPUSHs ((SV *)get_cv ("Coro::State::_coro_init", FALSE));
529 PUTBACK;
555 PL_op = (OP *)&myop; 530 PL_op = (OP *)&myop;
556
557 PUSHMARK(SP);
558 XPUSHs (sub_init);
559 PUTBACK;
560 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); 531 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
561 SPAGAIN; 532 SPAGAIN;
533 }
562 534
563 ENTER; /* necessary e.g. for dounwind */ 535 ENTER; /* necessary e.g. for dounwind */
564} 536}
565 537
566static void 538static void
… …
571 SvREFCNT_dec (coro_mortal); 543 SvREFCNT_dec (coro_mortal);
572 coro_mortal = 0; 544 coro_mortal = 0;
573 } 545 }
574} 546}
575 547
548/* inject a fake call to Coro::State::_cctx_init into the execution */
549static void NOINLINE
550prepare_cctx (coro_cctx *cctx)
551{
552 dSP;
553 LOGOP myop;
554
555 Zero (&myop, 1, LOGOP);
556 myop.op_next = PL_op;
557 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
558
559 PUSHMARK (SP);
560 EXTEND (SP, 2);
561 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
562 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
563 PUTBACK;
564 PL_op = (OP *)&myop;
565 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
566 SPAGAIN;
567}
568
576static void 569static void
577coro_run (void *arg) 570coro_run (void *arg)
578{ 571{
572 /* coro_run is the alternative tail of transfer(), so unlock here. */
573 UNLOCK;
574
579 /* 575 /*
580 * this is a _very_ stripped down perl interpreter ;) 576 * this is a _very_ stripped down perl interpreter ;)
581 */ 577 */
582 dTHX;
583 int ret;
584
585 UNLOCK;
586
587 PL_top_env = &PL_start_env; 578 PL_top_env = &PL_start_env;
588 579
589 sv_setiv (get_sv ("Coro::State::cctx_stack", FALSE), PTR2IV ((coro_stack *)arg)); 580 /* inject call to cctx_init */
590 sv_setiv (get_sv ("Coro::State::cctx_restartop", FALSE), PTR2IV (PL_op)); 581 prepare_cctx ((coro_cctx *)arg);
591
592 /* continue at cctx_init, without entersub */
593 PL_restartop = CvSTART (get_cv ("Coro::State::cctx_init", FALSE));
594 582
595 /* somebody will hit me for both perl_run and PL_restartop */ 583 /* somebody will hit me for both perl_run and PL_restartop */
596 ret = perl_run (PERL_GET_CONTEXT); 584 PL_restartop = PL_op;
597 printf ("ret %d\n", ret);//D 585 perl_run (PL_curinterp);
598 586
599 fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr); 587 fputs ("FATAL: C coroutine fell over the edge of the world, aborting. Did you call exit in a coroutine?\n", stderr);
600 abort (); 588 abort ();
601} 589}
602 590
603static coro_stack * 591static coro_cctx *
604stack_new () 592cctx_new ()
605{ 593{
606 coro_stack *stack; 594 coro_cctx *cctx;
607 595
596 ++cctx_count;
597
608 New (0, stack, 1, coro_stack); 598 Newz (0, cctx, 1, coro_cctx);
609 599
610#if HAVE_MMAP 600#if HAVE_MMAP
611 601
612 stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; 602 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
613 /* mmap suppsedly does allocate-on-write for us */ 603 /* mmap supposedly does allocate-on-write for us */
614 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); 604 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
615 605
616 if (stack->sptr == (void *)-1) 606 if (cctx->sptr == (void *)-1)
617 { 607 {
618 perror ("FATAL: unable to mmap stack for coroutine"); 608 perror ("FATAL: unable to mmap stack for coroutine");
619 _exit (EXIT_FAILURE); 609 _exit (EXIT_FAILURE);
620 } 610 }
621 611
622# if STACKGUARD 612# if STACKGUARD
623 mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE); 613 mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
624# endif 614# endif
625 615
626#else 616#else
627 617
628 stack->ssize = STACKSIZE * (long)sizeof (long); 618 cctx->ssize = STACKSIZE * (long)sizeof (long);
629 New (0, stack->sptr, STACKSIZE, long); 619 New (0, cctx->sptr, STACKSIZE, long);
630 620
631 if (!stack->sptr) 621 if (!cctx->sptr)
632 { 622 {
633 perror (stderr, "FATAL: unable to malloc stack for coroutine"); 623 perror ("FATAL: unable to malloc stack for coroutine");
634 _exit (EXIT_FAILURE); 624 _exit (EXIT_FAILURE);
635 } 625 }
636 626
637#endif 627#endif
638 628
629#if USE_VALGRIND
630 cctx->valgrind_id = VALGRIND_STACK_REGISTER (
631 STACKGUARD * PAGESIZE + (char *)cctx->sptr,
632 cctx->ssize + (char *)cctx->sptr
633 );
634#endif
635
639 coro_create (&stack->cctx, coro_run, (void *)stack, stack->sptr, stack->ssize); 636 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
640 637
641 return stack; 638 return cctx;
642} 639}
643 640
644static void 641static void
645stack_free (coro_stack *stack) 642cctx_destroy (coro_cctx *cctx)
646{ 643{
647 if (!stack) 644 if (!cctx)
648 return; 645 return;
649 646
647 --cctx_count;
648
649#if USE_VALGRIND
650 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
651#endif
652
650#if HAVE_MMAP 653#if HAVE_MMAP
651 munmap (stack->sptr, stack->ssize); 654 munmap (cctx->sptr, cctx->ssize);
652#else 655#else
653 Safefree (stack->sptr); 656 Safefree (cctx->sptr);
654#endif 657#endif
655 658
656 Safefree (stack); 659 Safefree (cctx);
657} 660}
658 661
659static coro_stack *stack_first;
660
661static coro_stack * 662static coro_cctx *
662stack_get () 663cctx_get ()
663{ 664{
664 coro_stack *stack; 665 coro_cctx *cctx;
665 666
666 if (stack_first) 667 if (cctx_first)
667 { 668 {
668 stack = stack_first; 669 cctx = cctx_first;
669 stack_first = stack->next; 670 cctx_first = cctx->next;
671 --cctx_idle;
670 } 672 }
671 else 673 else
672 { 674 {
673 stack = stack_new (); 675 cctx = cctx_new ();
674 PL_op = PL_op->op_next; 676 PL_op = PL_op->op_next;
675 } 677 }
676 678
677 return stack; 679 return cctx;
678} 680}
679 681
680static void 682static void
681stack_put (coro_stack *stack) 683cctx_put (coro_cctx *cctx)
682{ 684{
683 stack->next = stack_first; 685 /* free another cctx if overlimit */
684 stack_first = stack; 686 if (cctx_idle >= MAX_IDLE_CCTX)
687 {
688 coro_cctx *first = cctx_first;
689 cctx_first = first->next;
690 --cctx_idle;
691
692 assert (!first->inuse);
693 cctx_destroy (first);
694 }
695
696 ++cctx_idle;
697 cctx->next = cctx_first;
698 cctx_first = cctx;
685} 699}
686 700
687/* never call directly, always through the coro_state_transfer global variable */ 701/* never call directly, always through the coro_state_transfer global variable */
688static void 702static void NOINLINE
689transfer_impl (struct coro *prev, struct coro *next, int flags) 703transfer (struct coro *prev, struct coro *next)
690{ 704{
691 dSTACKLEVEL; 705 dSTACKLEVEL;
692 706
693 /* sometimes transfer is only called to set idle_sp */ 707 /* sometimes transfer is only called to set idle_sp */
694 if (flags == TRANSFER_SET_STACKLEVEL) 708 if (!next)
709 {
695 ((coro_stack *)prev)->idle_sp = STACKLEVEL; 710 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
711 assert (((coro_cctx *)prev)->top_env = PL_top_env); /* just for the side effetc when assert is enabled */
712 }
696 else if (prev != next) 713 else if (prev != next)
697 { 714 {
698 coro_stack *prev__stack; 715 coro_cctx *prev__cctx;
716
717 if (prev->flags & CF_NEW)
718 {
719 /* create a new empty context */
720 Newz (0, prev->cctx, 1, coro_cctx);
721 prev->cctx->inuse = 1;
722 prev->flags &= ~CF_NEW;
723 prev->flags |= CF_RUNNING;
724 }
725
726 /*TODO: must not croak here */
727 if (!prev->flags & CF_RUNNING)
728 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
729
730 if (next->flags & CF_RUNNING)
731 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
732
733 prev->flags &= ~CF_RUNNING;
734 next->flags |= CF_RUNNING;
699 735
700 LOCK; 736 LOCK;
701 737
702 if (next->mainstack) 738 if (next->flags & CF_NEW)
703 { 739 {
704 /* coroutine already started */ 740 /* need to start coroutine */
705 SAVE (prev, flags); 741 next->flags &= ~CF_NEW;
706 LOAD (next); 742 /* first get rid of the old state */
743 save_perl (prev);
744 /* setup coroutine call */
745 setup_coro (next);
746 /* need a new stack */
747 assert (!next->cctx);
707 } 748 }
708 else 749 else
709 { 750 {
710 /* need to start coroutine */ 751 /* coroutine already started */
711 /* first get rid of the old state */ 752 save_perl (prev);
712 SAVE (prev, -1); 753 load_perl (next);
713 /* setup coroutine call */
714 setup_coro (next);
715 /* need a stack */
716 next->stack = 0;
717 } 754 }
718 755
719 if (!prev->stack)
720 /* create a new empty context */
721 Newz (0, prev->stack, 1, coro_stack);
722
723 prev__stack = prev->stack; 756 prev__cctx = prev->cctx;
724 757
725 /* possibly "free" the stack */ 758 /* possibly "free" the cctx */
726 if (prev__stack->idle_sp == STACKLEVEL) 759 if (prev__cctx->idle_sp == STACKLEVEL)
727 { 760 {
728 stack_put (prev__stack); 761 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
762 assert (PL_top_env == prev__cctx->top_env);
763
729 prev->stack = 0; 764 prev->cctx = 0;
765
766 cctx_put (prev__cctx);
767 prev__cctx->inuse = 0;
730 } 768 }
731 769
732 if (!next->stack) 770 if (!next->cctx)
733 next->stack = stack_get ();
734
735 if (prev__stack != next->stack)
736 { 771 {
772 next->cctx = cctx_get ();
773 assert (!next->cctx->inuse);
774 next->cctx->inuse = 1;
775 }
776
777 if (prev__cctx != next->cctx)
778 {
737 prev__stack->top_env = PL_top_env; 779 prev__cctx->top_env = PL_top_env;
738 PL_top_env = next->stack->top_env; 780 PL_top_env = next->cctx->top_env;
739 coro_transfer (&prev__stack->cctx, &next->stack->cctx); 781 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
740 } 782 }
741 783
742 free_coro_mortal (); 784 free_coro_mortal ();
743 785
744 UNLOCK; 786 UNLOCK;
745 } 787 }
746} 788}
747 789
748/* use this function pointer to call the above function */
749/* this is done to increase chances of the compiler not inlining the call */
750/* not static to make it even harder for the compiler (and theoretically impossible in most cases */
751void (*coro_state_transfer)(struct coro *prev, struct coro *next, int flags) = transfer_impl;
752
753struct transfer_args 790struct transfer_args
754{ 791{
755 struct coro *prev, *next; 792 struct coro *prev, *next;
756 int flags;
757}; 793};
758 794
759#define TRANSFER(ta) coro_state_transfer ((ta).prev, (ta).next, (ta).flags) 795#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
760 796
761static void 797static void
762coro_state_destroy (struct coro *coro) 798coro_state_destroy (struct coro *coro)
763{ 799{
764 if (coro->refcnt--) 800 if (coro->refcnt--)
765 return; 801 return;
766 802
767 if (coro->mainstack && coro->mainstack != main_mainstack) 803 if (coro->mainstack && coro->mainstack != main_mainstack)
768 { 804 {
769 struct coro temp; 805 struct coro temp;
806 Zero (&temp, 1, struct coro);
807 temp.save = CORO_SAVE_ALL;
770 808
771 SAVE ((&temp), TRANSFER_SAVE_ALL); 809 if (coro->flags & CF_RUNNING)
772 LOAD (coro); 810 croak ("FATAL: tried to destroy currently running coroutine");
773 811
812 save_perl (&temp);
813 load_perl (coro);
814
774 destroy_stacks (); 815 coro_destroy_stacks ();
775 816
776 LOAD ((&temp)); /* this will get rid of defsv etc.. */ 817 load_perl (&temp); /* this will get rid of defsv etc.. */
777 818
778 coro->mainstack = 0; 819 coro->mainstack = 0;
779 } 820 }
780 821
781 stack_free (coro->stack); 822 cctx_destroy (coro->cctx);
782 SvREFCNT_dec (coro->args); 823 SvREFCNT_dec (coro->args);
783 Safefree (coro); 824 Safefree (coro);
784} 825}
785 826
786static int 827static int
… …
802 ++coro->refcnt; 843 ++coro->refcnt;
803 844
804 return 0; 845 return 0;
805} 846}
806 847
807static MGVTBL coro_state_vtbl = { 0, 0, 0, 0, coro_state_clear, 0, coro_state_dup, 0 }; 848static MGVTBL coro_state_vtbl = {
849 0, 0, 0, 0,
850 coro_state_clear,
851 0,
852#ifdef MGf_DUP
853 coro_state_dup,
854#else
855# define MGf_DUP 0
856#endif
857};
808 858
809static struct coro * 859static struct coro *
810SvSTATE (SV *coro) 860SvSTATE (SV *coro)
811{ 861{
812 HV *stash; 862 HV *stash;
… …
827 assert (mg->mg_type == PERL_MAGIC_ext); 877 assert (mg->mg_type == PERL_MAGIC_ext);
828 return (struct coro *)mg->mg_ptr; 878 return (struct coro *)mg->mg_ptr;
829} 879}
830 880
831static void 881static void
832prepare_transfer (struct transfer_args *ta, SV *prev, SV *next, int flags) 882prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
833{ 883{
834 ta->prev = SvSTATE (prev); 884 ta->prev = SvSTATE (prev_sv);
835 ta->next = SvSTATE (next); 885 ta->next = SvSTATE (next_sv);
836 ta->flags = flags;
837} 886}
838 887
839static void 888static void
840api_transfer (SV *prev, SV *next, int flags) 889api_transfer (SV *prev_sv, SV *next_sv)
841{ 890{
842 dTHX;
843 struct transfer_args ta; 891 struct transfer_args ta;
844 892
845 prepare_transfer (&ta, prev, next, flags); 893 prepare_transfer (&ta, prev_sv, next_sv);
846 TRANSFER (ta); 894 TRANSFER (ta);
895}
896
897static int
898api_save (SV *coro_sv, int new_save)
899{
900 struct coro *coro = SvSTATE (coro_sv);
901 int old_save = coro->save;
902
903 if (new_save >= 0)
904 coro->save = new_save;
905
906 return old_save;
847} 907}
848 908
849/** Coro ********************************************************************/ 909/** Coro ********************************************************************/
850 910
851#define PRIO_MAX 3 911#define PRIO_MAX 3
… …
854#define PRIO_LOW -1 914#define PRIO_LOW -1
855#define PRIO_IDLE -3 915#define PRIO_IDLE -3
856#define PRIO_MIN -4 916#define PRIO_MIN -4
857 917
858/* for Coro.pm */ 918/* for Coro.pm */
859static GV *coro_current, *coro_idle; 919static SV *coro_current;
860static AV *coro_ready [PRIO_MAX-PRIO_MIN+1]; 920static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
861static int coro_nready; 921static int coro_nready;
862 922
863static void 923static void
864coro_enq (SV *sv) 924coro_enq (SV *coro_sv)
865{ 925{
866 int prio;
867
868 if (SvTYPE (sv) != SVt_PVHV)
869 croak ("Coro::ready tried to enqueue something that is not a coroutine");
870
871 prio = SvSTATE (sv)->prio;
872
873 av_push (coro_ready [prio - PRIO_MIN], sv); 926 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
874 coro_nready++; 927 coro_nready++;
875} 928}
876 929
877static SV * 930static SV *
878coro_deq (int min_prio) 931coro_deq (int min_prio)
… …
891 } 944 }
892 945
893 return 0; 946 return 0;
894} 947}
895 948
896static void 949static int
897api_ready (SV *coro) 950api_ready (SV *coro_sv)
898{ 951{
899 dTHX; 952 struct coro *coro;
900 953
901 if (SvROK (coro)) 954 if (SvROK (coro_sv))
902 coro = SvRV (coro); 955 coro_sv = SvRV (coro_sv);
956
957 coro = SvSTATE (coro_sv);
958
959 if (coro->flags & CF_READY)
960 return 0;
961
962#if 0 /* this is actually harmless */
963 if (coro->flags & CF_RUNNING)
964 croak ("Coro::ready called on currently running coroutine");
965#endif
966
967 coro->flags |= CF_READY;
903 968
904 LOCK; 969 LOCK;
905 coro_enq (SvREFCNT_inc (coro)); 970 coro_enq (SvREFCNT_inc (coro_sv));
906 UNLOCK; 971 UNLOCK;
972
973 return 1;
974}
975
976static int
977api_is_ready (SV *coro_sv)
978{
979 return !!SvSTATE (coro_sv)->flags & CF_READY;
907} 980}
908 981
909static void 982static void
910prepare_schedule (struct transfer_args *ta) 983prepare_schedule (struct transfer_args *ta)
911{ 984{
912 SV *current, *prev, *next; 985 SV *prev, *next;
913
914 LOCK;
915
916 current = GvSV (coro_current);
917 986
918 for (;;) 987 for (;;)
919 { 988 {
920 LOCK; 989 LOCK;
921
922 next = coro_deq (PRIO_MIN); 990 next = coro_deq (PRIO_MIN);
991 UNLOCK;
923 992
924 if (next) 993 if (next)
925 break; 994 break;
926 995
927 UNLOCK;
928
929 { 996 {
930 dSP; 997 dSP;
931 998
932 ENTER; 999 ENTER;
933 SAVETMPS; 1000 SAVETMPS;
934 1001
935 PUSHMARK (SP); 1002 PUSHMARK (SP);
936 PUTBACK; 1003 PUTBACK;
937 call_sv (GvSV (coro_idle), G_DISCARD); 1004 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
938 1005
939 FREETMPS; 1006 FREETMPS;
940 LEAVE; 1007 LEAVE;
941 } 1008 }
942 } 1009 }
943 1010
944 prev = SvRV (current); 1011 prev = SvRV (coro_current);
945 SvRV (current) = next; 1012 SvRV_set (coro_current, next);
946 1013
947 /* free this only after the transfer */ 1014 /* free this only after the transfer */
1015 LOCK;
948 free_coro_mortal (); 1016 free_coro_mortal ();
1017 UNLOCK;
949 coro_mortal = prev; 1018 coro_mortal = prev;
950 1019
1020 assert (!SvROK(prev));//D
1021 assert (!SvROK(next));//D
1022
951 ta->prev = SvSTATE (prev); 1023 ta->prev = SvSTATE (prev);
952 ta->next = SvSTATE (next); 1024 ta->next = SvSTATE (next);
953 ta->flags = TRANSFER_SAVE_ALL;
954 1025
955 UNLOCK; 1026 assert (ta->next->flags & CF_READY);
1027 ta->next->flags &= ~CF_READY;
956} 1028}
957 1029
958static void 1030static void
959prepare_cede (struct transfer_args *ta) 1031prepare_cede (struct transfer_args *ta)
960{ 1032{
961 LOCK; 1033 api_ready (coro_current);
962 coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
963 UNLOCK;
964 1034
965 prepare_schedule (ta); 1035 prepare_schedule (ta);
966} 1036}
967 1037
968static void 1038static void
969api_schedule (void) 1039api_schedule (void)
970{ 1040{
971 dTHX;
972 struct transfer_args ta; 1041 struct transfer_args ta;
973 1042
974 prepare_schedule (&ta); 1043 prepare_schedule (&ta);
975 TRANSFER (ta); 1044 TRANSFER (ta);
976} 1045}
977 1046
978static void 1047static void
979api_cede (void) 1048api_cede (void)
980{ 1049{
981 dTHX;
982 struct transfer_args ta; 1050 struct transfer_args ta;
983 1051
984 prepare_cede (&ta); 1052 prepare_cede (&ta);
985 TRANSFER (ta); 1053 TRANSFER (ta);
986} 1054}
… …
996#endif 1064#endif
997 BOOT_PAGESIZE; 1065 BOOT_PAGESIZE;
998 1066
999 coro_state_stash = gv_stashpv ("Coro::State", TRUE); 1067 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1000 1068
1001 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV)); 1069 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
1002 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV)); 1070 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
1003 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV)); 1071 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
1072 newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
1073 newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
1004 1074
1005 main_mainstack = PL_mainstack; 1075 main_mainstack = PL_mainstack;
1006 1076
1007 coroapi.ver = CORO_API_VERSION; 1077 coroapi.ver = CORO_API_VERSION;
1008 coroapi.transfer = api_transfer; 1078 coroapi.transfer = api_transfer;
… …
1018 HV *hv; 1088 HV *hv;
1019 int i; 1089 int i;
1020 1090
1021 Newz (0, coro, 1, struct coro); 1091 Newz (0, coro, 1, struct coro);
1022 coro->args = newAV (); 1092 coro->args = newAV ();
1093 coro->save = CORO_SAVE_ALL;
1094 coro->flags = CF_NEW;
1023 1095
1024 hv = newHV (); 1096 hv = newHV ();
1025 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP; 1097 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1026 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1)); 1098 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1027 1099
1028 for (i = 1; i < items; i++) 1100 for (i = 1; i < items; i++)
1029 av_push (coro->args, newSVsv (ST (i))); 1101 av_push (coro->args, newSVsv (ST (i)));
1030
1031 /*coro->mainstack = 0; *//*actual work is done inside transfer */
1032 /*coro->stack = 0;*/
1033} 1102}
1034 OUTPUT: 1103 OUTPUT:
1104 RETVAL
1105
1106int
1107save (SV *coro, int new_save = -1)
1108 CODE:
1109 RETVAL = api_save (coro, new_save);
1110 OUTPUT:
1035 RETVAL 1111 RETVAL
1036 1112
1037void 1113void
1038_set_stacklevel (...) 1114_set_stacklevel (...)
1039 ALIAS: 1115 ALIAS:
1040 Coro::State::transfer = 1 1116 Coro::State::transfer = 1
1041 Coro::schedule = 2 1117 Coro::schedule = 2
1042 Coro::cede = 3 1118 Coro::cede = 3
1043 Coro::Cont::yield = 4
1044 CODE: 1119 CODE:
1045{ 1120{
1046 struct transfer_args ta; 1121 struct transfer_args ta;
1047 1122
1048 switch (ix) 1123 switch (ix)
1049 { 1124 {
1050 case 0: 1125 case 0:
1051 ta.prev = (struct coro *)INT2PTR (coro_stack *, SvIV (ST (0))); 1126 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1052 ta.next = 0; 1127 ta.next = 0;
1053 ta.flags = TRANSFER_SET_STACKLEVEL;
1054 break; 1128 break;
1055 1129
1056 case 1: 1130 case 1:
1057 if (items != 3) 1131 if (items != 2)
1058 croak ("Coro::State::transfer(prev,next,flags) expects three arguments, not %d", items); 1132 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
1059 1133
1060 prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2))); 1134 prepare_transfer (&ta, ST (0), ST (1));
1061 break; 1135 break;
1062 1136
1063 case 2: 1137 case 2:
1064 prepare_schedule (&ta); 1138 prepare_schedule (&ta);
1065 break; 1139 break;
1066 1140
1067 case 3: 1141 case 3:
1068 prepare_cede (&ta); 1142 prepare_cede (&ta);
1069 break; 1143 break;
1070
1071 case 4:
1072 {
1073 SV *yieldstack;
1074 SV *sv;
1075 AV *defav = GvAV (PL_defgv);
1076
1077 yieldstack = *hv_fetch (
1078 (HV *)SvRV (GvSV (coro_current)),
1079 "yieldstack", sizeof ("yieldstack") - 1,
1080 0
1081 );
1082
1083 /* set up @_ -- ugly */
1084 av_clear (defav);
1085 av_fill (defav, items - 1);
1086 while (items--)
1087 av_store (defav, items, SvREFCNT_inc (ST(items)));
1088
1089 sv = av_pop ((AV *)SvRV (yieldstack));
1090 ta.prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
1091 ta.next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
1092 ta.flags = 0;
1093 SvREFCNT_dec (sv);
1094 }
1095 break;
1096
1097 } 1144 }
1098 1145
1099 TRANSFER (ta); 1146 TRANSFER (ta);
1100} 1147}
1101 1148
… …
1108 sv_unmagic (SvRV (dst), PERL_MAGIC_ext); 1155 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1109 1156
1110 ++coro_src->refcnt; 1157 ++coro_src->refcnt;
1111 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP; 1158 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1112} 1159}
1113
1114void
1115_nonlocal_goto (IV nextop)
1116 CODE:
1117 /* uuh, somebody will kill me again for this */
1118 PL_op->op_next = INT2PTR (OP *, nextop);
1119 1160
1120void 1161void
1121_exit (code) 1162_exit (code)
1122 int code 1163 int code
1123 PROTOTYPE: $ 1164 PROTOTYPE: $
1124 CODE: 1165 CODE:
1125 _exit (code); 1166 _exit (code);
1126 1167
1168int
1169cctx_count ()
1170 CODE:
1171 RETVAL = cctx_count;
1172 OUTPUT:
1173 RETVAL
1174
1175int
1176cctx_idle ()
1177 CODE:
1178 RETVAL = cctx_idle;
1179 OUTPUT:
1180 RETVAL
1181
1127MODULE = Coro::State PACKAGE = Coro 1182MODULE = Coro::State PACKAGE = Coro
1128 1183
1129BOOT: 1184BOOT:
1130{ 1185{
1131 int i; 1186 int i;
… …
1137 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL)); 1192 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1138 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW)); 1193 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1139 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE)); 1194 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1140 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN)); 1195 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1141 1196
1142 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV); 1197 coro_current = get_sv ("Coro::current", FALSE);
1143 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV); 1198 SvREADONLY_on (coro_current);
1144 1199
1145 for (i = PRIO_MAX - PRIO_MIN + 1; i--; ) 1200 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1146 coro_ready[i] = newAV (); 1201 coro_ready[i] = newAV ();
1147 1202
1148 { 1203 {
1149 SV *sv = perl_get_sv("Coro::API", 1); 1204 SV *sv = perl_get_sv("Coro::API", 1);
1150 1205
1151 coroapi.schedule = api_schedule; 1206 coroapi.schedule = api_schedule;
1207 coroapi.save = api_save;
1152 coroapi.cede = api_cede; 1208 coroapi.cede = api_cede;
1153 coroapi.ready = api_ready; 1209 coroapi.ready = api_ready;
1210 coroapi.is_ready = api_is_ready;
1154 coroapi.nready = &coro_nready; 1211 coroapi.nready = &coro_nready;
1155 coroapi.current = coro_current; 1212 coroapi.current = coro_current;
1156 1213
1157 GCoroAPI = &coroapi; 1214 GCoroAPI = &coroapi;
1158 sv_setiv (sv, (IV)&coroapi); 1215 sv_setiv (sv, (IV)&coroapi);
1159 SvREADONLY_on (sv); 1216 SvREADONLY_on (sv);
1160 } 1217 }
1161} 1218}
1219
1220void
1221_set_current (SV *current)
1222 PROTOTYPE: $
1223 CODE:
1224 SvREFCNT_dec (SvRV (coro_current));
1225 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1162 1226
1163int 1227int
1164prio (Coro::State coro, int newprio = 0) 1228prio (Coro::State coro, int newprio = 0)
1165 ALIAS: 1229 ALIAS:
1166 nice = 1 1230 nice = 1
… …
1178 1242
1179 coro->prio = newprio; 1243 coro->prio = newprio;
1180 } 1244 }
1181} 1245}
1182 1246
1183void 1247SV *
1184ready (SV *self) 1248ready (SV *self)
1185 PROTOTYPE: $ 1249 PROTOTYPE: $
1186 CODE: 1250 CODE:
1187 api_ready (self); 1251 RETVAL = boolSV (api_ready (self));
1252 OUTPUT:
1253 RETVAL
1254
1255SV *
1256is_ready (SV *self)
1257 PROTOTYPE: $
1258 CODE:
1259 RETVAL = boolSV (api_is_ready (self));
1260 OUTPUT:
1261 RETVAL
1188 1262
1189int 1263int
1190nready (...) 1264nready (...)
1191 PROTOTYPE: 1265 PROTOTYPE:
1192 CODE: 1266 CODE:
… …
1198 1272
1199SV * 1273SV *
1200_get_state () 1274_get_state ()
1201 CODE: 1275 CODE:
1202{ 1276{
1203 struct { 1277 struct io_state *data;
1204 int errorno;
1205 int laststype;
1206 int laststatval;
1207 Stat_t statcache;
1208 } data;
1209 1278
1279 RETVAL = newSV (sizeof (struct io_state));
1280 data = (struct io_state *)SvPVX (RETVAL);
1281 SvCUR_set (RETVAL, sizeof (struct io_state));
1282 SvPOK_only (RETVAL);
1283
1210 data.errorno = errno; 1284 data->errorno = errno;
1211 data.laststype = PL_laststype; 1285 data->laststype = PL_laststype;
1212 data.laststatval = PL_laststatval; 1286 data->laststatval = PL_laststatval;
1213 data.statcache = PL_statcache; 1287 data->statcache = PL_statcache;
1214
1215 RETVAL = newSVpvn ((char *)&data, sizeof data);
1216} 1288}
1217 OUTPUT: 1289 OUTPUT:
1218 RETVAL 1290 RETVAL
1219 1291
1220void 1292void
1221_set_state (char *data_) 1293_set_state (char *data_)
1222 PROTOTYPE: $ 1294 PROTOTYPE: $
1223 CODE: 1295 CODE:
1224{ 1296{
1225 struct { 1297 struct io_state *data = (void *)data_;
1226 int errorno;
1227 int laststype;
1228 int laststatval;
1229 Stat_t statcache;
1230 } *data = (void *)data_;
1231 1298
1232 errno = data->errorno; 1299 errno = data->errorno;
1233 PL_laststype = data->laststype; 1300 PL_laststype = data->laststype;
1234 PL_laststatval = data->laststatval; 1301 PL_laststatval = data->laststatval;
1235 PL_statcache = data->statcache; 1302 PL_statcache = data->statcache;
1236} 1303}
1304

Diff Legend

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