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.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.173 by root, Sun Sep 30 13:41:45 2007 UTC

1#include "libcoro/coro.c"
2
3#define PERL_NO_GET_CONTEXT
4
1#include "EXTERN.h" 5#include "EXTERN.h"
2#include "perl.h" 6#include "perl.h"
3#include "XSUB.h" 7#include "XSUB.h"
4 8
5#if 0 9#include "patchlevel.h"
6# define CHK(x) (void *)0 10
11#include <stdio.h>
12#include <errno.h>
13#include <assert.h>
14
15#ifdef HAVE_MMAP
16# include <unistd.h>
17# include <sys/mman.h>
18# ifndef MAP_ANONYMOUS
19# ifdef MAP_ANON
20# define MAP_ANONYMOUS MAP_ANON
21# else
22# undef HAVE_MMAP
23# endif
24# endif
25# include <limits.h>
26# ifndef PAGESIZE
27# define PAGESIZE pagesize
28# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
29static long pagesize;
30# else
31# define BOOT_PAGESIZE (void)0
32# endif
7#else 33#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 34# define PAGESIZE 0
35# define BOOT_PAGESIZE (void)0
36#endif
37
38#if CORO_USE_VALGRIND
39# include <valgrind/valgrind.h>
40# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
41#else
42# define REGISTER_STACK(cctx,start,end)
43#endif
44
45/* the maximum number of idle cctx that will be pooled */
46#define MAX_IDLE_CCTX 8
47
48#define PERL_VERSION_ATLEAST(a,b,c) \
49 (PERL_REVISION > (a) \
50 || (PERL_REVISION == (a) \
51 && (PERL_VERSION > (b) \
52 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
53
54#if !PERL_VERSION_ATLEAST (5,6,0)
55# ifndef PL_ppaddr
56# define PL_ppaddr ppaddr
9#endif 57# endif
58# ifndef call_sv
59# define call_sv perl_call_sv
60# endif
61# ifndef get_sv
62# define get_sv perl_get_sv
63# endif
64# ifndef get_cv
65# define get_cv perl_get_cv
66# endif
67# ifndef IS_PADGV
68# define IS_PADGV(v) 0
69# endif
70# ifndef IS_PADCONST
71# define IS_PADCONST(v) 0
72# endif
73#endif
10 74
75/* 5.8.7 */
76#ifndef SvRV_set
77# define SvRV_set(s,v) SvRV(s) = (v)
78#endif
79
80#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
81# undef CORO_STACKGUARD
82#endif
83
84#ifndef CORO_STACKGUARD
85# define CORO_STACKGUARD 0
86#endif
87
88/* prefer perl internal functions over our own? */
89#ifndef CORO_PREFER_PERL_FUNCTIONS
90# define CORO_PREFER_PERL_FUNCTIONS 0
91#endif
92
93/* The next macros try to return the current stack pointer, in an as
94 * portable way as possible. */
95#define dSTACKLEVEL volatile char stacklevel
96#define STACKLEVEL ((void *)&stacklevel)
97
98#define IN_DESTRUCT (PL_main_cv == Nullcv)
99
100#if __GNUC__ >= 3
101# define attribute(x) __attribute__(x)
102# define BARRIER __asm__ __volatile__ ("" : : : "memory")
103#else
104# define attribute(x)
105# define BARRIER
106#endif
107
108#define NOINLINE attribute ((noinline))
109
110#include "CoroAPI.h"
111
112#ifdef USE_ITHREADS
113static perl_mutex coro_mutex;
114# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
115# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
116#else
117# define LOCK (void)0
118# define UNLOCK (void)0
119#endif
120
121/* helper storage struct for Coro::AIO */
122struct io_state
123{
124 int errorno;
125 I32 laststype;
126 int laststatval;
127 Stat_t statcache;
128};
129
130static size_t coro_stacksize = CORO_STACKSIZE;
131static struct CoroAPI coroapi;
132static AV *main_mainstack; /* used to differentiate between $main and others */
133static JMPENV *main_top_env;
134static HV *coro_state_stash, *coro_stash;
135static SV *coro_mortal; /* will be freed after next transfer */
136
137/* async_pool helper stuff */
138static SV *sv_pool_rss;
139static SV *sv_pool_size;
140static AV *av_async_pool;
141
142static struct coro_cctx *cctx_first;
143static int cctx_count, cctx_idle;
144
145enum {
146 CC_MAPPED = 0x01,
147 CC_NOREUSE = 0x02, /* throw this away after tracing */
148 CC_TRACE = 0x04,
149 CC_TRACE_SUB = 0x08, /* trace sub calls */
150 CC_TRACE_LINE = 0x10, /* trace each statement */
151 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
152};
153
154/* this is a structure representing a c-level coroutine */
155typedef struct coro_cctx {
156 struct coro_cctx *next;
157
158 /* the stack */
159 void *sptr;
160 size_t ssize;
161
162 /* cpu state */
163 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
164 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
165 JMPENV *top_env;
166 coro_context cctx;
167
168#if CORO_USE_VALGRIND
169 int valgrind_id;
170#endif
171 unsigned char flags;
172} coro_cctx;
173
174enum {
175 CF_RUNNING = 0x0001, /* coroutine is running */
176 CF_READY = 0x0002, /* coroutine is ready */
177 CF_NEW = 0x0004, /* has never been switched to */
178 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
179};
180
181/* this is a structure representing a perl-level coroutine */
11struct coro { 182struct coro {
12 U8 dowarn; 183 /* the c coroutine allocated to this perl coroutine, if any */
13 AV *defav; 184 coro_cctx *cctx;
185
186 /* data associated with this coroutine (initial args) */
187 AV *args;
188 int refcnt;
189 int save; /* CORO_SAVE flags */
190 int flags; /* CF_ flags */
191
192 /* optionally saved, might be zero */
193 AV *defav; /* @_ */
194 SV *defsv; /* $_ */
195 SV *errsv; /* $@ */
196 GV *deffh; /* default filehandle */
197 SV *irssv; /* $/ */
198 SV *irssv_sv; /* real $/ cache */
14 199
15 PERL_SI *curstackinfo; 200#define VAR(name,type) type name;
16 AV *curstack; 201# include "state.h"
17 AV *mainstack; 202#undef VAR
18 SV **stack_sp;
19 OP *op;
20 SV **curpad;
21 SV **stack_base;
22 SV **stack_max;
23 SV **tmps_stack;
24 I32 tmps_floor;
25 I32 tmps_ix;
26 I32 tmps_max;
27 I32 *markstack;
28 I32 *markstack_ptr;
29 I32 *markstack_max;
30 I32 *scopestack;
31 I32 scopestack_ix;
32 I32 scopestack_max;
33 ANY *savestack;
34 I32 savestack_ix;
35 I32 savestack_max;
36 OP **retstack;
37 I32 retstack_ix;
38 I32 retstack_max;
39 COP *curcop;
40 203
41 AV *args; 204 /* statistics */
205 int usecount; /* number of switches to this coro */
206
207 /* coro process data */
208 int prio;
209
210 /* linked list */
211 struct coro *next, *prev;
212 HV *hv; /* the perl hash associated with this coro, if any */
42}; 213};
43 214
44typedef struct coro *Coro__State; 215typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 216typedef struct coro *Coro__State_or_hashref;
46 217
47static HV *padlist_cache; 218/** Coro ********************************************************************/
48 219
49/* mostly copied from op.c:cv_clone2 */ 220#define PRIO_MAX 3
50STATIC AV * 221#define PRIO_HIGH 1
51clone_padlist (AV *protopadlist) 222#define PRIO_NORMAL 0
223#define PRIO_LOW -1
224#define PRIO_IDLE -3
225#define PRIO_MIN -4
226
227/* for Coro.pm */
228static SV *coro_current;
229static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
230static int coro_nready;
231static struct coro *coro_first;
232
233/** lowlevel stuff **********************************************************/
234
235static AV *
236coro_clone_padlist (pTHX_ CV *cv)
52{ 237{
53 AV *av; 238 AV *padlist = CvPADLIST (cv);
54 I32 ix;
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
57 SV **pname = AvARRAY (protopad_name);
58 SV **ppad = AvARRAY (protopad);
59 I32 fname = AvFILLp (protopad_name);
60 I32 fpad = AvFILLp (protopad);
61 AV *newpadlist, *newpad_name, *newpad; 239 AV *newpadlist, *newpad;
62 SV **npad;
63
64 newpad_name = newAV ();
65 for (ix = fname; ix >= 0; ix--)
66 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67
68 newpad = newAV ();
69 av_fill (newpad, AvFILLp (protopad));
70 npad = AvARRAY (newpad);
71 240
72 newpadlist = newAV (); 241 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 242 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 243#if PERL_VERSION_ATLEAST (5,9,0)
244 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
245#else
246 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
247#endif
248 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
249 --AvFILLp (padlist);
250
251 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 252 av_store (newpadlist, 1, (SV *)newpad);
76 253
77 av = newAV (); /* will be @_ */ 254 return newpadlist;
78 av_extend (av, 0); 255}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 256
82 for (ix = fpad; ix > 0; ix--) 257static void
258free_padlist (pTHX_ AV *padlist)
259{
260 /* may be during global destruction */
261 if (SvREFCNT (padlist))
83 { 262 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 263 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 264 while (i >= 0)
86 { 265 {
87 char *name = SvPVX (namesv); /* XXX */ 266 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 267 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 268 {
92 else
93 { /* our own lexical */
94 SV *sv; 269 SV *sv;
95 if (*name == '&') 270 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 271 SvREFCNT_dec (sv);
97 else if (*name == '@') 272
98 sv = (SV *) newAV (); 273 SvREFCNT_dec (*svp);
99 else if (*name == '%')
100 sv = (SV *) newHV ();
101 else
102 sv = NEWSV (0, 0);
103 if (!SvPADBUSY (sv))
104 SvPADMY_on (sv);
105 npad[ix] = sv;
106 } 274 }
107 } 275 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix])) 276
277 SvREFCNT_dec ((SV*)padlist);
278 }
279}
280
281static int
282coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
283{
284 AV *padlist;
285 AV *av = (AV *)mg->mg_obj;
286
287 /* casting is fun. */
288 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
289 free_padlist (aTHX_ padlist);
290
291 SvREFCNT_dec (av);
292
293 return 0;
294}
295
296#define PERL_MAGIC_coro PERL_MAGIC_ext
297
298static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
299
300#define CORO_MAGIC(cv) \
301 SvMAGIC (cv) \
302 ? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
303 ? SvMAGIC (cv) \
304 : mg_find ((SV *)cv, PERL_MAGIC_coro) \
305 : 0
306
307static struct coro *
308SvSTATE_ (pTHX_ SV *coro)
309{
310 HV *stash;
311 MAGIC *mg;
312
313 if (SvROK (coro))
314 coro = SvRV (coro);
315
316 if (SvTYPE (coro) != SVt_PVHV)
317 croak ("Coro::State object required");
318
319 stash = SvSTASH (coro);
320 if (stash != coro_stash && stash != coro_state_stash)
321 {
322 /* very slow, but rare, check */
323 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
324 croak ("Coro::State object required");
325 }
326
327 mg = CORO_MAGIC (coro);
328 return (struct coro *)mg->mg_ptr;
329}
330
331#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
332
333/* the next two functions merely cache the padlists */
334static void
335get_padlist (pTHX_ CV *cv)
336{
337 MAGIC *mg = CORO_MAGIC (cv);
338 AV *av;
339
340 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
341 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
342 else
343 {
344#if CORO_PREFER_PERL_FUNCTIONS
345 /* this is probably cleaner, but also slower? */
346 CV *cp = Perl_cv_clone (cv);
347 CvPADLIST (cv) = CvPADLIST (cp);
348 CvPADLIST (cp) = 0;
349 SvREFCNT_dec (cp);
350#else
351 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
352#endif
353 }
354}
355
356static void
357put_padlist (pTHX_ CV *cv)
358{
359 MAGIC *mg = CORO_MAGIC (cv);
360 AV *av;
361
362 if (!mg)
363 {
364 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
365 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
366 mg->mg_virtual = &vtbl_coro;
367 mg->mg_obj = (SV *)newAV ();
368 }
369
370 av = (AV *)mg->mg_obj;
371
372 if (AvFILLp (av) >= AvMAX (av))
373 av_extend (av, AvMAX (av) + 1);
374
375 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
376}
377
378/** load & save, init *******************************************************/
379
380#define SB do {
381#define SE } while (0)
382
383#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
384
385static void
386load_perl (pTHX_ Coro__State c)
387{
388#define VAR(name,type) PL_ ## name = c->name;
389# include "state.h"
390#undef VAR
391
392 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
393 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
394 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
395 if (c->deffh) REPLACE_SV (PL_defoutgv , c->deffh);
396
397 if (c->irssv)
398 {
399 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
109 { 400 {
110 npad[ix] = SvREFCNT_inc (ppad[ix]); 401 SvREFCNT_dec (c->irssv);
402 c->irssv = 0;
111 } 403 }
112 else 404 else
113 { 405 {
114 SV *sv = NEWSV (0, 0); 406 REPLACE_SV (PL_rs, c->irssv);
115 SvPADTMP_on (sv); 407 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
116 npad[ix] = sv; 408 sv_setsv (c->irssv_sv, PL_rs);
117 } 409 }
118 } 410 }
119 411
120#if 0 /* NONOTUNDERSTOOD */ 412 {
121 /* Now that vars are all in place, clone nested closures. */ 413 dSP;
414 CV *cv;
122 415
123 for (ix = fpad; ix > 0; ix--) { 416 /* now do the ugly restore mess */
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 417 while ((cv = (CV *)POPs))
125 if (namesv
126 && namesv != &PL_sv_undef
127 && !(SvFLAGS(namesv) & SVf_FAKE)
128 && *SvPVX(namesv) == '&'
129 && CvCLONE(ppad[ix]))
130 { 418 {
131 CV *kid = cv_clone((CV*)ppad[ix]); 419 put_padlist (aTHX_ cv); /* mark this padlist as available */
132 SvREFCNT_dec(ppad[ix]); 420 CvDEPTH (cv) = PTR2IV (POPs);
133 CvCLONE_on(kid); 421 CvPADLIST (cv) = (AV *)POPs;
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 } 422 }
137 }
138#endif
139 423
140 return newpadlist; 424 PUTBACK;
141}
142
143STATIC AV *
144free_padlist (AV *padlist)
145{
146 /* may be during global destruction */
147 if (SvREFCNT(padlist))
148 {
149 I32 i = AvFILLp(padlist);
150 while (i >= 0)
151 {
152 SV **svp = av_fetch(padlist, i--, FALSE);
153 SV *sv = svp ? *svp : Nullsv;
154 if (sv)
155 SvREFCNT_dec(sv);
156 }
157
158 SvREFCNT_dec((SV*)padlist);
159 } 425 }
160} 426}
161 427
162/* the next tow functions merely cache the padlists */
163STATIC void
164get_padlist (CV *cv)
165{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167
168 if (he && AvFILLp ((AV *)*he) >= 0)
169 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
170 else
171 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172}
173
174STATIC void
175put_padlist (CV *cv)
176{
177 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
178
179 if (SvTYPE (*he) != SVt_PVAV)
180 {
181 SvREFCNT_dec (*he);
182 *he = (SV *)newAV ();
183 }
184
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186}
187
188static void 428static void
189SAVE(pTHX_ Coro__State c) 429save_perl (pTHX_ Coro__State c)
190{ 430{
191 { 431 {
192 dSP; 432 dSP;
193 I32 cxix = cxstack_ix; 433 I32 cxix = cxstack_ix;
434 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 435 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 436
197 /* 437 /*
198 * the worst thing you can imagine happens first - we have to save 438 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 439 * (and reinitialize) all cv's in the whole callchain :(
200 */ 440 */
201 441
202 PUSHs (Nullsv); 442 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 443 /* this loop was inspired by pp_caller */
204 for (;;) 444 for (;;)
205 { 445 {
206 while (cxix >= 0) 446 while (cxix >= 0)
207 { 447 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 448 PERL_CONTEXT *cx = &ccstk[cxix--];
209 449
210 if (CxTYPE(cx) == CXt_SUB) 450 if (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT)
211 { 451 {
212 CV *cv = cx->blk_sub.cv; 452 CV *cv = cx->blk_sub.cv;
453
213 if (CvDEPTH(cv)) 454 if (CvDEPTH (cv))
214 { 455 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 456 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 457 PUSHs ((SV *)CvPADLIST (cv));
458 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 459 PUSHs ((SV *)cv);
222 460
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 461 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 462 get_padlist (aTHX_ cv);
227 CvOWNER(cv) = 0;
228 error must unlock this cv etc.. etc...
229 if you are here wondering about this error message then
230 the reason is that it will not work as advertised yet
231#endif
232 } 463 }
233 } 464 }
234 else if (CxTYPE(cx) == CXt_FORMAT)
235 {
236 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 }
240 } 465 }
241 466
242 if (top_si->si_type == PERLSI_MAIN) 467 if (top_si->si_type == PERLSI_MAIN)
243 break; 468 break;
244 469
245 top_si = top_si->si_prev; 470 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack; 471 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix; 472 cxix = top_si->si_cxix;
248 } 473 }
249 474
250 PUTBACK; 475 PUTBACK;
251 } 476 }
252 477
253 c->dowarn = PL_dowarn; 478 c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
254 c->defav = GvAV (PL_defgv); 479 c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
255 c->curstackinfo = PL_curstackinfo; 480 c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
256 c->curstack = PL_curstack; 481 c->deffh = c->save & CORO_SAVE_DEFFH ? (GV *)SvREFCNT_inc (PL_defoutgv) : 0;
257 c->mainstack = PL_mainstack; 482 c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
258 c->stack_sp = PL_stack_sp;
259 c->op = PL_op;
260 c->curpad = PL_curpad;
261 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max;
263 c->tmps_stack = PL_tmps_stack;
264 c->tmps_floor = PL_tmps_floor;
265 c->tmps_ix = PL_tmps_ix;
266 c->tmps_max = PL_tmps_max;
267 c->markstack = PL_markstack;
268 c->markstack_ptr = PL_markstack_ptr;
269 c->markstack_max = PL_markstack_max;
270 c->scopestack = PL_scopestack;
271 c->scopestack_ix = PL_scopestack_ix;
272 c->scopestack_max = PL_scopestack_max;
273 c->savestack = PL_savestack;
274 c->savestack_ix = PL_savestack_ix;
275 c->savestack_max = PL_savestack_max;
276 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop;
280}
281 483
484#define VAR(name,type)c->name = PL_ ## name;
485# include "state.h"
486#undef VAR
487}
488
489/*
490 * allocate various perl stacks. This is an exact copy
491 * of perl.c:init_stacks, except that it uses less memory
492 * on the (sometimes correct) assumption that coroutines do
493 * not usually need a lot of stackspace.
494 */
495#if CORO_PREFER_PERL_FUNCTIONS
496# define coro_init_stacks init_stacks
497#else
282static void 498static void
283LOAD(pTHX_ Coro__State c) 499coro_init_stacks (pTHX)
284{ 500{
285 PL_dowarn = c->dowarn;
286 GvAV (PL_defgv) = c->defav;
287 PL_curstackinfo = c->curstackinfo; 501 PL_curstackinfo = new_stackinfo(64, 6);
288 PL_curstack = c->curstack; 502 PL_curstackinfo->si_type = PERLSI_MAIN;
289 PL_mainstack = c->mainstack; 503 PL_curstack = PL_curstackinfo->si_stack;
504 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
505
506 PL_stack_base = AvARRAY(PL_curstack);
290 PL_stack_sp = c->stack_sp; 507 PL_stack_sp = PL_stack_base;
291 PL_op = c->op; 508 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292 PL_curpad = c->curpad; 509
293 PL_stack_base = c->stack_base; 510 New(50,PL_tmps_stack,64,SV*);
294 PL_stack_max = c->stack_max; 511 PL_tmps_floor = -1;
295 PL_tmps_stack = c->tmps_stack; 512 PL_tmps_ix = -1;
296 PL_tmps_floor = c->tmps_floor; 513 PL_tmps_max = 64;
297 PL_tmps_ix = c->tmps_ix; 514
298 PL_tmps_max = c->tmps_max; 515 New(54,PL_markstack,16,I32);
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr; 516 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 517 PL_markstack_max = PL_markstack + 16;
302 PL_scopestack = c->scopestack; 518
303 PL_scopestack_ix = c->scopestack_ix; 519#ifdef SET_MARK_OFFSET
304 PL_scopestack_max = c->scopestack_max; 520 SET_MARK_OFFSET;
305 PL_savestack = c->savestack; 521#endif
306 PL_savestack_ix = c->savestack_ix; 522
307 PL_savestack_max = c->savestack_max; 523 New(54,PL_scopestack,16,I32);
308 PL_retstack = c->retstack; 524 PL_scopestack_ix = 0;
309 PL_retstack_ix = c->retstack_ix; 525 PL_scopestack_max = 16;
310 PL_retstack_max = c->retstack_max; 526
311 PL_curcop = c->curcop; 527 New(54,PL_savestack,64,ANY);
528 PL_savestack_ix = 0;
529 PL_savestack_max = 64;
530
531#if !PERL_VERSION_ATLEAST (5,9,0)
532 New(54,PL_retstack,4,OP*);
533 PL_retstack_ix = 0;
534 PL_retstack_max = 4;
535#endif
536}
537#endif
538
539/*
540 * destroy the stacks, the callchain etc...
541 */
542static void
543coro_destroy_stacks (pTHX)
544{
545 if (!IN_DESTRUCT)
546 {
547 /* restore all saved variables and stuff */
548 LEAVE_SCOPE (0);
549 assert (PL_tmps_floor == -1);
550
551 /* free all temporaries */
552 FREETMPS;
553 assert (PL_tmps_ix == -1);
554
555 /* unwind all extra stacks */
556 POPSTACK_TO (PL_mainstack);
557
558 /* unwind main stack */
559 dounwind (-1);
560 }
561
562 while (PL_curstackinfo->si_next)
563 PL_curstackinfo = PL_curstackinfo->si_next;
564
565 while (PL_curstackinfo)
566 {
567 PERL_SI *p = PL_curstackinfo->si_prev;
568
569 if (!IN_DESTRUCT)
570 SvREFCNT_dec (PL_curstackinfo->si_stack);
571
572 Safefree (PL_curstackinfo->si_cxstack);
573 Safefree (PL_curstackinfo);
574 PL_curstackinfo = p;
575 }
576
577 Safefree (PL_tmps_stack);
578 Safefree (PL_markstack);
579 Safefree (PL_scopestack);
580 Safefree (PL_savestack);
581#if !PERL_VERSION_ATLEAST (5,9,0)
582 Safefree (PL_retstack);
583#endif
584}
585
586static size_t
587coro_rss (pTHX_ struct coro *coro)
588{
589 size_t rss = sizeof (coro);
590
591 if (coro->mainstack)
592 {
593 if (coro->flags & CF_RUNNING)
594 {
595 #define VAR(name,type)coro->name = PL_ ## name;
596 # include "state.h"
597 #undef VAR
598 }
599
600 rss += sizeof (coro->curstackinfo);
601 rss += sizeof (struct xpvav) + (1 + AvFILL (coro->curstackinfo->si_stack)) * sizeof (SV *);
602 rss += (coro->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
603 rss += sizeof (struct xpvav) + (1 + AvFILL (coro->curstack)) * sizeof (SV *);
604 rss += coro->tmps_max * sizeof (SV *);
605 rss += (coro->markstack_max - coro->markstack_ptr) * sizeof (I32);
606 rss += coro->scopestack_max * sizeof (I32);
607 rss += coro->savestack_max * sizeof (ANY);
608
609#if !PERL_VERSION_ATLEAST (5,9,0)
610 rss += coro->retstack_max * sizeof (OP *);
611#endif
612 }
613
614 return rss;
615}
616
617/** coroutine stack handling ************************************************/
618
619static void
620setup_coro (pTHX_ struct coro *coro)
621{
622 /*
623 * emulate part of the perl startup here.
624 */
625 coro_init_stacks (aTHX);
626
627 PL_runops = RUNOPS_DEFAULT;
628 PL_curcop = &PL_compiling;
629 PL_in_eval = EVAL_NULL;
630 PL_comppad = 0;
631 PL_curpm = 0;
632 PL_localizing = 0;
633 PL_dirty = 0;
634 PL_restartop = 0;
312 635
313 { 636 {
314 dSP; 637 dSP;
315 CV *cv; 638 LOGOP myop;
316 639
317 /* now do the ugly restore mess */ 640 SvREFCNT_dec (GvAV (PL_defgv));
318 while ((cv = (CV *)POPs)) 641 GvAV (PL_defgv) = coro->args; coro->args = 0;
319 {
320 AV *padlist = (AV *)POPs;
321 642
322 put_padlist (cv); 643 Zero (&myop, 1, LOGOP);
323 CvPADLIST(cv) = padlist; 644 myop.op_next = Nullop;
324 CvDEPTH(cv) = (I32)POPs; 645 myop.op_flags = OPf_WANT_VOID;
325 646
326#ifdef USE_THREADS 647 PUSHMARK (SP);
327 CvOWNER(cv) = (struct perl_thread *)POPs; 648 XPUSHs (av_shift (GvAV (PL_defgv)));
328 error does not work either
329#endif
330 }
331
332 PUTBACK; 649 PUTBACK;
650 PL_op = (OP *)&myop;
651 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
652 SPAGAIN;
333 } 653 }
334}
335 654
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 655 ENTER; /* necessary e.g. for dounwind */
337STATIC void 656}
338destroy_stacks(pTHX) 657
658static void
659free_coro_mortal (pTHX)
660{
661 if (coro_mortal)
662 {
663 SvREFCNT_dec (coro_mortal);
664 coro_mortal = 0;
665 }
666}
667
668static int
669runops_trace (pTHX)
670{
671 COP *oldcop = 0;
672 int oldcxix = -2;
673 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
674 coro_cctx *cctx = coro->cctx;
675
676 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
677 {
678 PERL_ASYNC_CHECK ();
679
680 if (cctx->flags & CC_TRACE_ALL)
681 {
682 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
683 {
684 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
685 SV **bot, **top;
686 AV *av = newAV (); /* return values */
687 SV **cb;
688 dSP;
689
690 GV *gv = CvGV (cx->blk_sub.cv);
691 SV *fullname = sv_2mortal (newSV (0));
692 if (isGV (gv))
693 gv_efullname3 (fullname, gv, 0);
694
695 bot = PL_stack_base + cx->blk_oldsp + 1;
696 top = cx->blk_gimme == G_ARRAY ? SP + 1
697 : cx->blk_gimme == G_SCALAR ? bot + 1
698 : bot;
699
700 while (bot < top)
701 av_push (av, SvREFCNT_inc (*bot++));
702
703 PL_runops = RUNOPS_DEFAULT;
704 ENTER;
705 SAVETMPS;
706 EXTEND (SP, 3);
707 PUSHMARK (SP);
708 PUSHs (&PL_sv_no);
709 PUSHs (fullname);
710 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
711 PUTBACK;
712 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
713 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
714 SPAGAIN;
715 FREETMPS;
716 LEAVE;
717 PL_runops = runops_trace;
718 }
719
720 if (oldcop != PL_curcop)
721 {
722 oldcop = PL_curcop;
723
724 if (PL_curcop != &PL_compiling)
725 {
726 SV **cb;
727
728 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
729 {
730 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
731
732 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
733 {
734 runops_proc_t old_runops = PL_runops;
735 dSP;
736 GV *gv = CvGV (cx->blk_sub.cv);
737 SV *fullname = sv_2mortal (newSV (0));
738
739 if (isGV (gv))
740 gv_efullname3 (fullname, gv, 0);
741
742 PL_runops = RUNOPS_DEFAULT;
743 ENTER;
744 SAVETMPS;
745 EXTEND (SP, 3);
746 PUSHMARK (SP);
747 PUSHs (&PL_sv_yes);
748 PUSHs (fullname);
749 PUSHs (cx->blk_sub.hasargs ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
750 PUTBACK;
751 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
752 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
753 SPAGAIN;
754 FREETMPS;
755 LEAVE;
756 PL_runops = runops_trace;
757 }
758
759 oldcxix = cxstack_ix;
760 }
761
762 if (cctx->flags & CC_TRACE_LINE)
763 {
764 dSP;
765
766 PL_runops = RUNOPS_DEFAULT;
767 ENTER;
768 SAVETMPS;
769 EXTEND (SP, 3);
770 PL_runops = RUNOPS_DEFAULT;
771 PUSHMARK (SP);
772 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
773 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
774 PUTBACK;
775 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
776 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
777 SPAGAIN;
778 FREETMPS;
779 LEAVE;
780 PL_runops = runops_trace;
781 }
782 }
783 }
784 }
785 }
786
787 TAINT_NOT;
788 return 0;
789}
790
791/* inject a fake call to Coro::State::_cctx_init into the execution */
792/* _cctx_init should be careful, as it could be called at almost any time */
793/* during execution of a perl program */
794static void NOINLINE
795prepare_cctx (pTHX_ coro_cctx *cctx)
339{ 796{
340 dSP; 797 dSP;
798 LOGOP myop;
341 799
342 /* die does this while calling POPSTACK, but I just don't see why. */ 800 PL_top_env = &PL_start_env;
343 dounwind(-1);
344 801
345 /* is this ugly, I ask? */ 802 if (cctx->flags & CC_TRACE)
346 while (PL_scopestack_ix) 803 PL_runops = runops_trace;
347 LEAVE;
348 804
349 while (PL_curstackinfo->si_next) 805 Zero (&myop, 1, LOGOP);
350 PL_curstackinfo = PL_curstackinfo->si_next; 806 myop.op_next = PL_op;
807 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
351 808
352 while (PL_curstackinfo) 809 PUSHMARK (SP);
353 { 810 EXTEND (SP, 2);
354 PERL_SI *p = PL_curstackinfo->si_prev; 811 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
812 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
813 PUTBACK;
814 PL_op = (OP *)&myop;
815 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
816 SPAGAIN;
817}
355 818
356 SvREFCNT_dec(PL_curstackinfo->si_stack); 819/*
357 Safefree(PL_curstackinfo->si_cxstack); 820 * this is a _very_ stripped down perl interpreter ;)
358 Safefree(PL_curstackinfo); 821 */
359 PL_curstackinfo = p; 822static void
360 } 823coro_run (void *arg)
824{
825 dTHX;
361 826
362 if (PL_scopestack_ix != 0) 827 /* coro_run is the alternative tail of transfer(), so unlock here. */
363 Perl_warner(aTHX_ WARN_INTERNAL, 828 UNLOCK;
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 829
365 (long)PL_scopestack_ix); 830 /* we now skip the entersub that lead to transfer() */
366 if (PL_savestack_ix != 0) 831 PL_op = PL_op->op_next;
367 Perl_warner(aTHX_ WARN_INTERNAL, 832
368 "Unbalanced saves: %ld more saves than restores\n", 833 /* inject a fake subroutine call to cctx_init */
369 (long)PL_savestack_ix); 834 prepare_cctx (aTHX_ (coro_cctx *)arg);
370 if (PL_tmps_floor != -1) 835
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 836 /* somebody or something will hit me for both perl_run and PL_restartop */
372 (long)PL_tmps_floor + 1); 837 PL_restartop = PL_op;
838 perl_run (PL_curinterp);
839
373 /* 840 /*
374 */ 841 * If perl-run returns we assume exit() was being called or the coro
375 Safefree(PL_tmps_stack); 842 * fell off the end, which seems to be the only valid (non-bug)
376 Safefree(PL_markstack); 843 * reason for perl_run to return. We try to exit by jumping to the
377 Safefree(PL_scopestack); 844 * bootstrap-time "top" top_env, as we cannot restore the "main"
378 Safefree(PL_savestack); 845 * coroutine as Coro has no such concept
379 Safefree(PL_retstack); 846 */
847 PL_top_env = main_top_env;
848 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
380} 849}
381 850
382#define SUB_INIT "Coro::State::_newcoro" 851static coro_cctx *
852cctx_new ()
853{
854 coro_cctx *cctx;
855 void *stack_start;
856 size_t stack_size;
383 857
858 ++cctx_count;
859
860 Newz (0, cctx, 1, coro_cctx);
861
862#if HAVE_MMAP
863
864 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
865 /* mmap supposedly does allocate-on-write for us */
866 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
867
868 if (cctx->sptr != (void *)-1)
869 {
870# if CORO_STACKGUARD
871 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
872# endif
873 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
874 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
875 cctx->flags |= CC_MAPPED;
876 }
877 else
878#endif
879 {
880 cctx->ssize = coro_stacksize * (long)sizeof (long);
881 New (0, cctx->sptr, coro_stacksize, long);
882
883 if (!cctx->sptr)
884 {
885 perror ("FATAL: unable to allocate stack for coroutine");
886 _exit (EXIT_FAILURE);
887 }
888
889 stack_start = cctx->sptr;
890 stack_size = cctx->ssize;
891 }
892
893 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
894 coro_create (&cctx->cctx, coro_run, (void *)cctx, stack_start, stack_size);
895
896 return cctx;
897}
898
899static void
900cctx_destroy (coro_cctx *cctx)
901{
902 if (!cctx)
903 return;
904
905 --cctx_count;
906
907#if CORO_USE_VALGRIND
908 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
909#endif
910
911#if HAVE_MMAP
912 if (cctx->flags & CC_MAPPED)
913 munmap (cctx->sptr, cctx->ssize);
914 else
915#endif
916 Safefree (cctx->sptr);
917
918 Safefree (cctx);
919}
920
921static coro_cctx *
922cctx_get (pTHX)
923{
924 while (cctx_first)
925 {
926 coro_cctx *cctx = cctx_first;
927 cctx_first = cctx->next;
928 --cctx_idle;
929
930 if (cctx->ssize >= coro_stacksize && !(cctx->flags & CC_NOREUSE))
931 return cctx;
932
933 cctx_destroy (cctx);
934 }
935
936 return cctx_new ();
937}
938
939static void
940cctx_put (coro_cctx *cctx)
941{
942 /* free another cctx if overlimit */
943 if (cctx_idle >= MAX_IDLE_CCTX)
944 {
945 coro_cctx *first = cctx_first;
946 cctx_first = first->next;
947 --cctx_idle;
948
949 cctx_destroy (first);
950 }
951
952 ++cctx_idle;
953 cctx->next = cctx_first;
954 cctx_first = cctx;
955}
956
957/** coroutine switching *****************************************************/
958
959static void NOINLINE
960transfer_check (pTHX_ struct coro *prev, struct coro *next)
961{
962 if (prev != next)
963 {
964 if (!(prev->flags & (CF_RUNNING | CF_NEW)))
965 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
966
967 if (next->flags & CF_RUNNING)
968 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
969
970 if (next->flags & CF_DESTROYED)
971 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
972
973 if (PL_lex_state != LEX_NOTPARSING)
974 croak ("Coro::State::transfer called while parsing, but this is not supported");
975 }
976}
977
978/* always use the TRANSFER macro */
979static void NOINLINE
980transfer (pTHX_ struct coro *prev, struct coro *next)
981{
982 dSTACKLEVEL;
983
984 /* sometimes transfer is only called to set idle_sp */
985 if (!next)
986 {
987 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
988 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
989 }
990 else if (prev != next)
991 {
992 coro_cctx *prev__cctx;
993
994 if (prev->flags & CF_NEW)
995 {
996 /* create a new empty context */
997 Newz (0, prev->cctx, 1, coro_cctx);
998 prev->flags &= ~CF_NEW;
999 prev->flags |= CF_RUNNING;
1000 }
1001
1002 prev->flags &= ~CF_RUNNING;
1003 next->flags |= CF_RUNNING;
1004
1005 LOCK;
1006
1007 if (next->flags & CF_NEW)
1008 {
1009 /* need to start coroutine */
1010 next->flags &= ~CF_NEW;
1011 /* first get rid of the old state */
1012 save_perl (aTHX_ prev);
1013 /* setup coroutine call */
1014 setup_coro (aTHX_ next);
1015 }
1016 else
1017 {
1018 /* coroutine already started */
1019 save_perl (aTHX_ prev);
1020 load_perl (aTHX_ next);
1021 }
1022
1023 prev__cctx = prev->cctx;
1024
1025 /* possibly "free" the cctx */
1026 if (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE))
1027 {
1028 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1029 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1030
1031 prev->cctx = 0;
1032
1033 cctx_put (prev__cctx);
1034 }
1035
1036 ++next->usecount;
1037
1038 if (!next->cctx)
1039 next->cctx = cctx_get (aTHX);
1040
1041 if (prev__cctx != next->cctx)
1042 {
1043 prev__cctx->top_env = PL_top_env;
1044 PL_top_env = next->cctx->top_env;
1045 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1046 }
1047
1048 free_coro_mortal (aTHX);
1049 UNLOCK;
1050 }
1051}
1052
1053struct transfer_args
1054{
1055 struct coro *prev, *next;
1056};
1057
1058#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1059#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1060
1061/** high level stuff ********************************************************/
1062
1063static int
1064coro_state_destroy (pTHX_ struct coro *coro)
1065{
1066 if (coro->flags & CF_DESTROYED)
1067 return 0;
1068
1069 coro->flags |= CF_DESTROYED;
1070
1071 if (coro->flags & CF_READY)
1072 {
1073 /* reduce nready, as destroying a ready coro effectively unreadies it */
1074 /* alternative: look through all ready queues and remove the coro */
1075 LOCK;
1076 --coro_nready;
1077 UNLOCK;
1078 }
1079 else
1080 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1081
1082 if (coro->mainstack && coro->mainstack != main_mainstack)
1083 {
1084 struct coro temp;
1085
1086 assert (!(coro->flags & CF_RUNNING));
1087
1088 Zero (&temp, 1, struct coro);
1089 temp.save = CORO_SAVE_ALL;
1090
1091 if (coro->flags & CF_RUNNING)
1092 croak ("FATAL: tried to destroy currently running coroutine");
1093
1094 save_perl (aTHX_ &temp);
1095 load_perl (aTHX_ coro);
1096
1097 coro_destroy_stacks (aTHX);
1098
1099 load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
1100
1101 coro->mainstack = 0;
1102 }
1103
1104 cctx_destroy (coro->cctx);
1105 SvREFCNT_dec (coro->args);
1106
1107 if (coro->next) coro->next->prev = coro->prev;
1108 if (coro->prev) coro->prev->next = coro->next;
1109 if (coro == coro_first) coro_first = coro->next;
1110
1111 return 1;
1112}
1113
1114static int
1115coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1116{
1117 struct coro *coro = (struct coro *)mg->mg_ptr;
1118 mg->mg_ptr = 0;
1119
1120 coro->hv = 0;
1121
1122 if (--coro->refcnt < 0)
1123 {
1124 coro_state_destroy (aTHX_ coro);
1125 Safefree (coro);
1126 }
1127
1128 return 0;
1129}
1130
1131static int
1132coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1133{
1134 struct coro *coro = (struct coro *)mg->mg_ptr;
1135
1136 ++coro->refcnt;
1137
1138 return 0;
1139}
1140
1141static MGVTBL coro_state_vtbl = {
1142 0, 0, 0, 0,
1143 coro_state_free,
1144 0,
1145#ifdef MGf_DUP
1146 coro_state_dup,
1147#else
1148# define MGf_DUP 0
1149#endif
1150};
1151
1152static void
1153prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1154{
1155 ta->prev = SvSTATE (prev_sv);
1156 ta->next = SvSTATE (next_sv);
1157 TRANSFER_CHECK (*ta);
1158}
1159
1160static void
1161api_transfer (SV *prev_sv, SV *next_sv)
1162{
1163 dTHX;
1164 struct transfer_args ta;
1165
1166 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1167 TRANSFER (ta);
1168}
1169
1170static int
1171api_save (SV *coro_sv, int new_save)
1172{
1173 dTHX;
1174 struct coro *coro = SvSTATE (coro_sv);
1175 int old_save = coro->save;
1176
1177 if (new_save >= 0)
1178 coro->save = new_save;
1179
1180 return old_save;
1181}
1182
1183/** Coro ********************************************************************/
1184
1185static void
1186coro_enq (pTHX_ SV *coro_sv)
1187{
1188 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1189}
1190
1191static SV *
1192coro_deq (pTHX_ int min_prio)
1193{
1194 int prio = PRIO_MAX - PRIO_MIN;
1195
1196 min_prio -= PRIO_MIN;
1197 if (min_prio < 0)
1198 min_prio = 0;
1199
1200 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1201 if (AvFILLp (coro_ready [prio]) >= 0)
1202 return av_shift (coro_ready [prio]);
1203
1204 return 0;
1205}
1206
1207static int
1208api_ready (SV *coro_sv)
1209{
1210 dTHX;
1211 struct coro *coro;
1212
1213 if (SvROK (coro_sv))
1214 coro_sv = SvRV (coro_sv);
1215
1216 coro = SvSTATE (coro_sv);
1217
1218 if (coro->flags & CF_READY)
1219 return 0;
1220
1221 coro->flags |= CF_READY;
1222
1223 LOCK;
1224 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1225 ++coro_nready;
1226 UNLOCK;
1227
1228 return 1;
1229}
1230
1231static int
1232api_is_ready (SV *coro_sv)
1233{
1234 dTHX;
1235 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1236}
1237
1238static void
1239prepare_schedule (pTHX_ struct transfer_args *ta)
1240{
1241 SV *prev_sv, *next_sv;
1242
1243 for (;;)
1244 {
1245 LOCK;
1246 next_sv = coro_deq (aTHX_ PRIO_MIN);
1247
1248 /* nothing to schedule: call the idle handler */
1249 if (!next_sv)
1250 {
1251 dSP;
1252 UNLOCK;
1253
1254 ENTER;
1255 SAVETMPS;
1256
1257 PUSHMARK (SP);
1258 PUTBACK;
1259 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1260
1261 FREETMPS;
1262 LEAVE;
1263 continue;
1264 }
1265
1266 ta->next = SvSTATE (next_sv);
1267
1268 /* cannot transfer to destroyed coros, skip and look for next */
1269 if (ta->next->flags & CF_DESTROYED)
1270 {
1271 UNLOCK;
1272 SvREFCNT_dec (next_sv);
1273 /* coro_nready is already taken care of by destroy */
1274 continue;
1275 }
1276
1277 --coro_nready;
1278 UNLOCK;
1279 break;
1280 }
1281
1282 /* free this only after the transfer */
1283 prev_sv = SvRV (coro_current);
1284 ta->prev = SvSTATE (prev_sv);
1285 TRANSFER_CHECK (*ta);
1286 assert (ta->next->flags & CF_READY);
1287 ta->next->flags &= ~CF_READY;
1288 SvRV_set (coro_current, next_sv);
1289
1290 LOCK;
1291 free_coro_mortal (aTHX);
1292 coro_mortal = prev_sv;
1293 UNLOCK;
1294}
1295
1296static void
1297prepare_cede (pTHX_ struct transfer_args *ta)
1298{
1299 api_ready (coro_current);
1300 prepare_schedule (aTHX_ ta);
1301}
1302
1303static int
1304prepare_cede_notself (pTHX_ struct transfer_args *ta)
1305{
1306 if (coro_nready)
1307 {
1308 SV *prev = SvRV (coro_current);
1309 prepare_schedule (aTHX_ ta);
1310 api_ready (prev);
1311 return 1;
1312 }
1313 else
1314 return 0;
1315}
1316
1317static void
1318api_schedule (void)
1319{
1320 dTHX;
1321 struct transfer_args ta;
1322
1323 prepare_schedule (aTHX_ &ta);
1324 TRANSFER (ta);
1325}
1326
1327static int
1328api_cede (void)
1329{
1330 dTHX;
1331 struct transfer_args ta;
1332
1333 prepare_cede (aTHX_ &ta);
1334
1335 if (ta.prev != ta.next)
1336 {
1337 TRANSFER (ta);
1338 return 1;
1339 }
1340 else
1341 return 0;
1342}
1343
1344static int
1345api_cede_notself (void)
1346{
1347 dTHX;
1348 struct transfer_args ta;
1349
1350 if (prepare_cede_notself (aTHX_ &ta))
1351 {
1352 TRANSFER (ta);
1353 return 1;
1354 }
1355 else
1356 return 0;
1357}
1358
1359static void
1360api_trace (struct coro *coro, int flags)
1361{
1362 dTHX;
1363
1364 if (flags & CC_TRACE)
1365 {
1366 if (!coro->cctx)
1367 coro->cctx = cctx_new ();
1368 else if (!(coro->cctx->flags & CC_TRACE))
1369 croak ("cannot enable tracing on coroutine with custom stack");
1370
1371 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1372 }
1373 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1374 {
1375 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1376
1377 if (coro->flags & CF_RUNNING)
1378 PL_runops = RUNOPS_DEFAULT;
1379 else
1380 coro->runops = RUNOPS_DEFAULT;
1381 }
1382}
1383
384MODULE = Coro::State PACKAGE = Coro::State 1384MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
385 1385
386PROTOTYPES: ENABLE 1386PROTOTYPES: DISABLE
387 1387
388BOOT: 1388BOOT:
389 if (!padlist_cache) 1389{
390 padlist_cache = newHV (); 1390#ifdef USE_ITHREADS
1391 MUTEX_INIT (&coro_mutex);
1392#endif
1393 BOOT_PAGESIZE;
391 1394
392Coro::State 1395 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
393_newprocess(args) 1396
394 SV * args 1397 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
395 PROTOTYPE: $ 1398 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1399 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1400 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1401
1402 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
1403 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
1404 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
1405 newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
1406 newCONSTSUB (coro_state_stash, "SAVE_DEFFH", newSViv (CORO_SAVE_DEFFH));
1407 newCONSTSUB (coro_state_stash, "SAVE_DEF", newSViv (CORO_SAVE_DEF));
1408 newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
1409
1410 main_mainstack = PL_mainstack;
1411 main_top_env = PL_top_env;
1412
1413 while (main_top_env->je_prev)
1414 main_top_env = main_top_env->je_prev;
1415
1416 coroapi.ver = CORO_API_VERSION;
1417 coroapi.transfer = api_transfer;
1418
1419 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1420}
1421
1422SV *
1423new (char *klass, ...)
396 CODE: 1424 CODE:
397 Coro__State coro; 1425{
1426 struct coro *coro;
1427 HV *hv;
1428 int i;
398 1429
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400 croak ("Coro::State::newprocess expects an arrayref");
401
402 New (0, coro, 1, struct coro); 1430 Newz (0, coro, 1, struct coro);
1431 coro->args = newAV ();
1432 coro->save = CORO_SAVE_DEF;
1433 coro->flags = CF_NEW;
403 1434
404 coro->mainstack = 0; /* actual work is done inside transfer */ 1435 if (coro_first) coro_first->prev = coro;
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1436 coro->next = coro_first;
1437 coro_first = coro;
406 1438
407 RETVAL = coro; 1439 coro->hv = hv = newHV ();
1440 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1441 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1442
1443 for (i = 1; i < items; i++)
1444 av_push (coro->args, newSVsv (ST (i)));
1445}
408 OUTPUT: 1446 OUTPUT:
409 RETVAL 1447 RETVAL
410 1448
1449int
1450save (SV *coro, int new_save = -1)
1451 CODE:
1452 RETVAL = api_save (coro, new_save);
1453 OUTPUT:
1454 RETVAL
1455
1456int
1457save_also (SV *coro_sv, int save_also)
1458 CODE:
1459{
1460 struct coro *coro = SvSTATE (coro_sv);
1461 RETVAL = coro->save;
1462 coro->save |= save_also;
1463}
1464 OUTPUT:
1465 RETVAL
1466
411void 1467void
412transfer(prev,next) 1468_set_stacklevel (...)
413 Coro::State_or_hashref prev 1469 ALIAS:
414 Coro::State_or_hashref next 1470 Coro::State::transfer = 1
1471 Coro::schedule = 2
1472 Coro::cede = 3
1473 Coro::cede_notself = 4
415 CODE: 1474 CODE:
1475{
1476 struct transfer_args ta;
416 1477
417 if (prev != next) 1478 switch (ix)
418 { 1479 {
419 PUTBACK;
420 SAVE (aTHX_ prev);
421
422 /*
423 * this could be done in newprocess which would lead to
424 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425 * code here, but lazy allocation of stacks has also
426 * some virtues and the overhead of the if() is nil.
427 */
428 if (next->mainstack)
429 {
430 LOAD (aTHX_ next);
431 next->mainstack = 0; /* unnecessary but much cleaner */
432 SPAGAIN;
433 }
434 else 1480 case 0:
1481 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1482 ta.next = 0;
435 { 1483 break;
436 /*
437 * emulate part of the perl startup here.
438 */
439 UNOP myop;
440 1484
441 init_stacks (); /* from perl.c */ 1485 case 1:
442 PL_op = (OP *)&myop; 1486 if (items != 2)
443 /*PL_curcop = 0;*/ 1487 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445 1488
446 SPAGAIN; 1489 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
447 Zero(&myop, 1, UNOP);
448 myop.op_next = Nullop;
449 myop.op_flags = OPf_WANT_VOID;
450
451 PUSHMARK(SP);
452 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453 PUTBACK;
454 /*
455 * the next line is slightly wrong, as PL_op->op_next
456 * is actually being executed so we skip the first op.
457 * that doesn't matter, though, since it is only
458 * pp_nextstate and we never return...
459 */
460 PL_op = Perl_pp_entersub(aTHX);
461 SPAGAIN;
462
463 ENTER;
464 } 1490 break;
1491
1492 case 2:
1493 prepare_schedule (aTHX_ &ta);
1494 break;
1495
1496 case 3:
1497 prepare_cede (aTHX_ &ta);
1498 break;
1499
1500 case 4:
1501 if (!prepare_cede_notself (aTHX_ &ta))
1502 XSRETURN_EMPTY;
1503
1504 break;
465 } 1505 }
466 1506
1507 BARRIER;
1508 TRANSFER (ta);
1509
1510 if (GIMME_V != G_VOID && ta.next != ta.prev)
1511 XSRETURN_YES;
1512}
1513
1514bool
1515_destroy (SV *coro_sv)
1516 CODE:
1517 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1518 OUTPUT:
1519 RETVAL
1520
467void 1521void
468DESTROY(coro) 1522_exit (code)
469 Coro::State coro 1523 int code
470 CODE: 1524 PROTOTYPE: $
1525 CODE:
1526 _exit (code);
471 1527
1528int
1529cctx_stacksize (int new_stacksize = 0)
1530 CODE:
1531 RETVAL = coro_stacksize;
1532 if (new_stacksize)
1533 coro_stacksize = new_stacksize;
1534 OUTPUT:
1535 RETVAL
1536
1537int
1538cctx_count ()
1539 CODE:
1540 RETVAL = cctx_count;
1541 OUTPUT:
1542 RETVAL
1543
1544int
1545cctx_idle ()
1546 CODE:
1547 RETVAL = cctx_idle;
1548 OUTPUT:
1549 RETVAL
1550
1551void
1552list ()
1553 PPCODE:
1554{
1555 struct coro *coro;
1556 for (coro = coro_first; coro; coro = coro->next)
1557 if (coro->hv)
1558 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1559}
1560
1561void
1562call (Coro::State coro, SV *coderef)
1563 ALIAS:
1564 eval = 1
1565 CODE:
1566{
472 if (coro->mainstack) 1567 if (coro->mainstack)
473 { 1568 {
474 struct coro temp; 1569 struct coro temp;
1570 Zero (&temp, 1, struct coro);
1571 temp.save = CORO_SAVE_ALL;
475 1572
1573 if (!(coro->flags & CF_RUNNING))
1574 {
1575 save_perl (aTHX_ &temp);
1576 load_perl (aTHX_ coro);
1577 }
1578
1579 {
1580 dSP;
1581 ENTER;
1582 SAVETMPS;
1583 PUSHMARK (SP);
476 PUTBACK; 1584 PUTBACK;
477 SAVE(aTHX_ (&temp)); 1585 if (ix)
478 LOAD(aTHX_ coro); 1586 eval_sv (coderef, 0);
479 1587 else
480 destroy_stacks (); 1588 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483 LOAD((&temp));
484 SPAGAIN; 1589 SPAGAIN;
1590 FREETMPS;
1591 LEAVE;
1592 PUTBACK;
1593 }
1594
1595 if (!(coro->flags & CF_RUNNING))
1596 {
1597 save_perl (aTHX_ coro);
1598 load_perl (aTHX_ &temp);
1599 }
485 } 1600 }
1601}
486 1602
1603SV *
1604is_ready (Coro::State coro)
1605 PROTOTYPE: $
1606 ALIAS:
1607 is_ready = CF_READY
1608 is_running = CF_RUNNING
1609 is_new = CF_NEW
1610 is_destroyed = CF_DESTROYED
1611 CODE:
1612 RETVAL = boolSV (coro->flags & ix);
1613 OUTPUT:
1614 RETVAL
1615
1616void
1617api_trace (Coro::State coro, int flags = CC_TRACE | CC_TRACE_SUB)
1618
1619SV *
1620has_stack (Coro::State coro)
1621 PROTOTYPE: $
1622 CODE:
1623 RETVAL = boolSV (!!coro->cctx);
1624 OUTPUT:
1625 RETVAL
1626
1627int
1628is_traced (Coro::State coro)
1629 PROTOTYPE: $
1630 CODE:
1631 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1632 OUTPUT:
1633 RETVAL
1634
1635IV
1636rss (Coro::State coro)
1637 PROTOTYPE: $
1638 ALIAS:
1639 usecount = 1
1640 CODE:
1641 switch (ix)
1642 {
1643 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1644 case 1: RETVAL = coro->usecount; break;
1645 }
1646 OUTPUT:
1647 RETVAL
1648
1649
1650MODULE = Coro::State PACKAGE = Coro
1651
1652BOOT:
1653{
1654 int i;
1655
1656 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1657 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1658 av_async_pool = get_av ("Coro::async_pool", TRUE);
1659
1660 coro_current = get_sv ("Coro::current", FALSE);
1661 SvREADONLY_on (coro_current);
1662
1663 coro_stash = gv_stashpv ("Coro", TRUE);
1664
1665 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1666 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1667 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1668 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1669 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1670 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1671
1672 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1673 coro_ready[i] = newAV ();
1674
1675 {
1676 SV *sv = perl_get_sv("Coro::API", 1);
1677
1678 coroapi.schedule = api_schedule;
1679 coroapi.save = api_save;
1680 coroapi.cede = api_cede;
1681 coroapi.cede_notself = api_cede_notself;
1682 coroapi.ready = api_ready;
1683 coroapi.is_ready = api_is_ready;
1684 coroapi.nready = &coro_nready;
1685 coroapi.current = coro_current;
1686
1687 GCoroAPI = &coroapi;
1688 sv_setiv (sv, (IV)&coroapi);
1689 SvREADONLY_on (sv);
1690 }
1691}
1692
1693void
1694_set_current (SV *current)
1695 PROTOTYPE: $
1696 CODE:
1697 SvREFCNT_dec (SvRV (coro_current));
1698 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1699
1700int
1701prio (Coro::State coro, int newprio = 0)
1702 ALIAS:
1703 nice = 1
1704 CODE:
1705{
1706 RETVAL = coro->prio;
1707
1708 if (items > 1)
1709 {
1710 if (ix)
1711 newprio = coro->prio - newprio;
1712
1713 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1714 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1715
1716 coro->prio = newprio;
1717 }
1718}
1719 OUTPUT:
1720 RETVAL
1721
1722SV *
1723ready (SV *self)
1724 PROTOTYPE: $
1725 CODE:
1726 RETVAL = boolSV (api_ready (self));
1727 OUTPUT:
1728 RETVAL
1729
1730int
1731nready (...)
1732 PROTOTYPE:
1733 CODE:
1734 RETVAL = coro_nready;
1735 OUTPUT:
1736 RETVAL
1737
1738# for async_pool speedup
1739void
1740_pool_1 (SV *cb)
1741 CODE:
1742{
1743 int i, len;
1744 HV *hv = (HV *)SvRV (coro_current);
1745 AV *defav = GvAV (PL_defgv);
1746 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1747 AV *invoke_av;
1748
1749 if (!invoke)
1750 croak ("\3terminate\2\n");
1751
1752 hv_store (hv, "desc", sizeof ("desc") - 1,
1753 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
1754
1755 invoke_av = (AV *)SvRV (invoke);
1756 len = av_len (invoke_av);
1757
1758 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1759
1760 if (len > 0)
1761 {
1762 av_fill (defav, len - 1);
1763 for (i = 0; i < len; ++i)
1764 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1765 }
1766
487 SvREFCNT_dec (coro->args); 1767 SvREFCNT_dec (invoke);
488 Safefree (coro); 1768}
489 1769
1770void
1771_pool_2 (SV *cb)
1772 CODE:
1773{
1774 struct coro *coro = SvSTATE (coro_current);
490 1775
1776 sv_setsv (cb, &PL_sv_undef);
1777
1778 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1779 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1780 croak ("\3terminate\2\n");
1781
1782 av_clear (GvAV (PL_defgv));
1783 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1784 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1785 coro->save = CORO_SAVE_DEF;
1786 coro->prio = 0;
1787
1788 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1789 api_trace (coro, 0);
1790
1791 av_push (av_async_pool, newSVsv (coro_current));
1792}
1793
1794
1795MODULE = Coro::State PACKAGE = Coro::AIO
1796
1797SV *
1798_get_state ()
1799 CODE:
1800{
1801 struct io_state *data;
1802
1803 RETVAL = newSV (sizeof (struct io_state));
1804 data = (struct io_state *)SvPVX (RETVAL);
1805 SvCUR_set (RETVAL, sizeof (struct io_state));
1806 SvPOK_only (RETVAL);
1807
1808 data->errorno = errno;
1809 data->laststype = PL_laststype;
1810 data->laststatval = PL_laststatval;
1811 data->statcache = PL_statcache;
1812}
1813 OUTPUT:
1814 RETVAL
1815
1816void
1817_set_state (char *data_)
1818 PROTOTYPE: $
1819 CODE:
1820{
1821 struct io_state *data = (void *)data_;
1822
1823 errno = data->errorno;
1824 PL_laststype = data->laststype;
1825 PL_laststatval = data->laststatval;
1826 PL_statcache = data->statcache;
1827}
1828

Diff Legend

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