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.12 by root, Sun Jul 22 03:24:10 2001 UTC vs.
Revision 1.87 by root, Fri Nov 24 13:40:36 2006 UTC

1#define PERL_NO_GET_CONTEXT
2
3#include "libcoro/coro.c"
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 1 9#include "patchlevel.h"
6# define CHK(x) (void *)0 10
11#if PERL_VERSION < 6
12# ifndef PL_ppaddr
13# define PL_ppaddr ppaddr
14# endif
15# ifndef call_sv
16# define call_sv perl_call_sv
17# endif
18# ifndef get_sv
19# define get_sv perl_get_sv
20# endif
21# ifndef get_cv
22# define get_cv perl_get_cv
23# endif
24# ifndef IS_PADGV
25# define IS_PADGV(v) 0
26# endif
27# ifndef IS_PADCONST
28# define IS_PADCONST(v) 0
29# endif
30#endif
31
32#include <errno.h>
33
34#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
35# undef STACKGUARD
36#endif
37
38#ifndef STACKGUARD
39# define STACKGUARD 0
40#endif
41
42#ifdef HAVE_MMAP
43# include <unistd.h>
44# include <sys/mman.h>
45# ifndef MAP_ANONYMOUS
46# ifdef MAP_ANON
47# define MAP_ANONYMOUS MAP_ANON
48# else
49# undef HAVE_MMAP
50# endif
51# endif
52# include <limits.h>
53# ifndef PAGESIZE
54# define PAGESIZE pagesize
55# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
56static long pagesize;
57# else
58# define BOOT_PAGESIZE
59# endif
60#endif
61
62#define SUB_INIT "Coro::State::initialize"
63#define UCORO_STATE "_coro_state"
64
65/* The next macro should declare a variable stacklevel that contains and approximation
66 * to the current C stack pointer. Its property is that it changes with each call
67 * and should be unique. */
68#define dSTACKLEVEL void *stacklevel = &stacklevel
69
70#define IN_DESTRUCT (PL_main_cv == Nullcv)
71
72#define labs(l) ((l) >= 0 ? (l) : -(l))
73
74#include "CoroAPI.h"
75
76#ifdef USE_ITHREADS
77static perl_mutex coro_mutex;
78# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
79# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
7#else 80#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 81# define LOCK (void)0
82# define UNLOCK (void)0
9#endif 83#endif
10 84
11#define MAY_FLUSH /* increases codesize */ 85static struct CoroAPI coroapi;
86static AV *main_mainstack; /* used to differentiate between $main and others */
87static HV *coro_state_stash;
88static SV *ucoro_state_sv;
89static U32 ucoro_state_hash;
90static SV *coro_mortal; /* will be freed after next transfer */
12 91
13#define SUB_INIT "Coro::State::initialize" 92/* this is actually not only the c stack but also c registers etc... */
93typedef struct {
94 int refcnt; /* pointer reference counter */
95 int usecnt; /* shared by how many coroutines */
96 int gencnt; /* generation counter */
14 97
15#define TRANSFER_SAVE_DEFAV 0x00000001 98 coro_context cctx;
16#define TRANSFER_SAVE_DEFSV 0x00000002
17#define TRANSFER_SAVE_ERRSV 0x00000004
18 99
19#define TRANSFER_SAVE_ALL -1 100 void *sptr;
101 long ssize; /* positive == mmap, otherwise malloc */
102} coro_stack;
20 103
21struct coro { 104struct coro {
105 /* the optional C context */
106 coro_stack *stack;
107 void *cursp;
108 int gencnt;
109
22 /* optionally saved, might be zero */ 110 /* optionally saved, might be zero */
23 AV *defav; 111 AV *defav;
24 SV *defsv; 112 SV *defsv;
25 SV *errsv; 113 SV *errsv;
26 114
27 /* saved global state not related to stacks */ 115 /* saved global state not related to stacks */
28 U8 dowarn; 116 U8 dowarn;
117 I32 in_eval;
29 118
30 /* the stacks and related info (callchain etc..) */ 119 /* the stacks and related info (callchain etc..) */
31 PERL_SI *curstackinfo; 120 PERL_SI *curstackinfo;
32 AV *curstack; 121 AV *curstack;
33 AV *mainstack; 122 AV *mainstack;
34 SV **stack_sp; 123 SV **stack_sp;
35 OP *op; 124 OP *op;
36 SV **curpad; 125 SV **curpad;
126 AV *comppad;
127 CV *compcv;
37 SV **stack_base; 128 SV **stack_base;
38 SV **stack_max; 129 SV **stack_max;
39 SV **tmps_stack; 130 SV **tmps_stack;
40 I32 tmps_floor; 131 I32 tmps_floor;
41 I32 tmps_ix; 132 I32 tmps_ix;
… …
50 I32 savestack_ix; 141 I32 savestack_ix;
51 I32 savestack_max; 142 I32 savestack_max;
52 OP **retstack; 143 OP **retstack;
53 I32 retstack_ix; 144 I32 retstack_ix;
54 I32 retstack_max; 145 I32 retstack_max;
146 PMOP *curpm;
55 COP *curcop; 147 COP *curcop;
148 JMPENV *top_env;
149
150 /* coro process data */
151 int prio;
56 152
57 /* data associated with this coroutine (initial args) */ 153 /* data associated with this coroutine (initial args) */
58 AV *args; 154 AV *args;
155 int refcnt;
59}; 156};
60 157
61typedef struct coro *Coro__State; 158typedef struct coro *Coro__State;
62typedef struct coro *Coro__State_or_hashref; 159typedef struct coro *Coro__State_or_hashref;
63 160
64static AV *main_mainstack; /* used to differentiate between $main and others */ 161static AV *
65 162coro_clone_padlist (pTHX_ CV *cv)
66static HV *padlist_cache;
67
68/* mostly copied from op.c:cv_clone2 */
69STATIC AV *
70clone_padlist (AV *protopadlist)
71{ 163{
72 AV *av; 164 AV *padlist = CvPADLIST (cv);
73 I32 ix;
74 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
75 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
76 SV **pname = AvARRAY (protopad_name);
77 SV **ppad = AvARRAY (protopad);
78 I32 fname = AvFILLp (protopad_name);
79 I32 fpad = AvFILLp (protopad);
80 AV *newpadlist, *newpad_name, *newpad; 165 AV *newpadlist, *newpad;
81 SV **npad;
82
83 newpad_name = newAV ();
84 for (ix = fname; ix >= 0; ix--)
85 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
86
87 newpad = newAV ();
88 av_fill (newpad, AvFILLp (protopad));
89 npad = AvARRAY (newpad);
90 166
91 newpadlist = newAV (); 167 newpadlist = newAV ();
92 AvREAL_off (newpadlist); 168 AvREAL_off (newpadlist);
93 av_store (newpadlist, 0, (SV *) newpad_name); 169#if PERL_VERSION < 9
170 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
171#else
172 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
173#endif
174 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
175 --AvFILLp (padlist);
176
177 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
94 av_store (newpadlist, 1, (SV *) newpad); 178 av_store (newpadlist, 1, (SV *)newpad);
95 179
96 av = newAV (); /* will be @_ */ 180 return newpadlist;
97 av_extend (av, 0); 181}
98 av_store (newpad, 0, (SV *) av);
99 AvFLAGS (av) = AVf_REIFY;
100 182
101 for (ix = fpad; ix > 0; ix--) 183static void
184free_padlist (pTHX_ AV *padlist)
185{
186 /* may be during global destruction */
187 if (SvREFCNT (padlist))
102 { 188 {
103 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 189 I32 i = AvFILLp (padlist);
104 if (namesv && namesv != &PL_sv_undef) 190 while (i >= 0)
105 { 191 {
106 char *name = SvPVX (namesv); /* XXX */ 192 SV **svp = av_fetch (padlist, i--, FALSE);
107 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 193 if (svp)
108 { /* lexical from outside? */
109 npad[ix] = SvREFCNT_inc (ppad[ix]);
110 } 194 {
111 else
112 { /* our own lexical */
113 SV *sv; 195 SV *sv;
114 if (*name == '&') 196 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
115 sv = SvREFCNT_inc (ppad[ix]); 197 SvREFCNT_dec (sv);
116 else if (*name == '@') 198
117 sv = (SV *) newAV (); 199 SvREFCNT_dec (*svp);
118 else if (*name == '%')
119 sv = (SV *) newHV ();
120 else
121 sv = NEWSV (0, 0);
122 if (!SvPADBUSY (sv))
123 SvPADMY_on (sv);
124 npad[ix] = sv;
125 } 200 }
126 } 201 }
127 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix])) 202
128 { 203 SvREFCNT_dec ((SV*)padlist);
129 npad[ix] = SvREFCNT_inc (ppad[ix]);
130 }
131 else
132 {
133 SV *sv = NEWSV (0, 0);
134 SvPADTMP_on (sv);
135 npad[ix] = sv;
136 }
137 } 204 }
205}
138 206
139#if 0 /* return -ENOTUNDERSTOOD */ 207static int
140 /* Now that vars are all in place, clone nested closures. */ 208coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
209{
210 AV *padlist;
211 AV *av = (AV *)mg->mg_obj;
141 212
142 for (ix = fpad; ix > 0; ix--) { 213 /* casting is fun. */
143 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 214 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
144 if (namesv 215 free_padlist (aTHX_ padlist);
145 && namesv != &PL_sv_undef 216
146 && !(SvFLAGS(namesv) & SVf_FAKE) 217 SvREFCNT_dec (av);
147 && *SvPVX(namesv) == '&' 218
148 && CvCLONE(ppad[ix])) 219 return 0;
149 { 220}
150 CV *kid = cv_clone((CV*)ppad[ix]); 221
151 SvREFCNT_dec(ppad[ix]); 222#define PERL_MAGIC_coro PERL_MAGIC_ext
152 CvCLONE_on(kid); 223
153 SvPADMY_on(kid); 224static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
154 npad[ix] = (SV*)kid; 225
155 } 226/* the next two functions merely cache the padlists */
227static void
228get_padlist (pTHX_ CV *cv)
229{
230 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
231
232 if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0)
233 CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj);
234 else
235 {
236#if 0
237 /* this should work - but it doesn't :( */
238 CV *cp = Perl_cv_clone (aTHX_ cv);
239 CvPADLIST (cv) = CvPADLIST (cp);
240 CvPADLIST (cp) = 0;
241 SvREFCNT_dec (cp);
242#else
243 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
244#endif
245 }
246}
247
248static void
249put_padlist (pTHX_ CV *cv)
250{
251 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
252
253 if (!mg)
254 {
255 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
256 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
257 mg->mg_virtual = &vtbl_coro;
258 mg->mg_obj = (SV *)newAV ();
156 } 259 }
157#endif
158 260
159 return newpadlist;
160}
161
162#ifdef MAY_FLUSH
163STATIC AV *
164free_padlist (AV *padlist)
165{
166 /* may be during global destruction */
167 if (SvREFCNT(padlist))
168 {
169 I32 i = AvFILLp(padlist);
170 while (i >= 0)
171 {
172 SV **svp = av_fetch(padlist, i--, FALSE);
173 SV *sv = svp ? *svp : Nullsv;
174 if (sv)
175 SvREFCNT_dec(sv);
176 }
177
178 SvREFCNT_dec((SV*)padlist);
179 }
180}
181#endif
182
183/* the next two functions merely cache the padlists */
184STATIC void
185get_padlist (CV *cv)
186{
187 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
188
189 if (he && AvFILLp ((AV *)*he) >= 0)
190 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
191 else
192 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
193}
194
195STATIC void
196put_padlist (CV *cv)
197{
198 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
199
200 if (SvTYPE (*he) != SVt_PVAV)
201 {
202 SvREFCNT_dec (*he);
203 *he = (SV *)newAV ();
204 }
205
206 av_push ((AV *)*he, (SV *)CvPADLIST (cv)); 261 av_push ((AV *)mg->mg_obj, (SV *)CvPADLIST (cv));
207} 262}
208
209#ifdef MAY_FLUSH
210STATIC void
211flush_padlist_cache ()
212{
213 HV *hv = padlist_cache;
214 padlist_cache = newHV ();
215
216 if (hv_iterinit (hv))
217 {
218 HE *he;
219 AV *padlist;
220
221 while (!!(he = hv_iternext (hv)))
222 {
223 AV *av = (AV *)HeVAL(he);
224
225 /* casting is fun. */
226 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
227 free_padlist (padlist);
228 }
229 }
230
231 SvREFCNT_dec (hv);
232}
233#endif
234 263
235#define SB do { 264#define SB do {
236#define SE } while (0) 265#define SE } while (0)
237 266
238#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE 267#define LOAD(state) load_state(aTHX_ (state));
239#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE 268#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
240 269
241#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE 270#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
242 271
243static void 272static void
244load_state(pTHX_ Coro__State c) 273load_state(pTHX_ Coro__State c)
245{ 274{
246 PL_dowarn = c->dowarn; 275 PL_dowarn = c->dowarn;
276 PL_in_eval = c->in_eval;
247 277
248 PL_curstackinfo = c->curstackinfo; 278 PL_curstackinfo = c->curstackinfo;
249 PL_curstack = c->curstack; 279 PL_curstack = c->curstack;
250 PL_mainstack = c->mainstack; 280 PL_mainstack = c->mainstack;
251 PL_stack_sp = c->stack_sp; 281 PL_stack_sp = c->stack_sp;
252 PL_op = c->op; 282 PL_op = c->op;
253 PL_curpad = c->curpad; 283 PL_curpad = c->curpad;
284 PL_comppad = c->comppad;
285 PL_compcv = c->compcv;
254 PL_stack_base = c->stack_base; 286 PL_stack_base = c->stack_base;
255 PL_stack_max = c->stack_max; 287 PL_stack_max = c->stack_max;
256 PL_tmps_stack = c->tmps_stack; 288 PL_tmps_stack = c->tmps_stack;
257 PL_tmps_floor = c->tmps_floor; 289 PL_tmps_floor = c->tmps_floor;
258 PL_tmps_ix = c->tmps_ix; 290 PL_tmps_ix = c->tmps_ix;
… …
264 PL_scopestack_ix = c->scopestack_ix; 296 PL_scopestack_ix = c->scopestack_ix;
265 PL_scopestack_max = c->scopestack_max; 297 PL_scopestack_max = c->scopestack_max;
266 PL_savestack = c->savestack; 298 PL_savestack = c->savestack;
267 PL_savestack_ix = c->savestack_ix; 299 PL_savestack_ix = c->savestack_ix;
268 PL_savestack_max = c->savestack_max; 300 PL_savestack_max = c->savestack_max;
301#if PERL_VERSION < 9
269 PL_retstack = c->retstack; 302 PL_retstack = c->retstack;
270 PL_retstack_ix = c->retstack_ix; 303 PL_retstack_ix = c->retstack_ix;
271 PL_retstack_max = c->retstack_max; 304 PL_retstack_max = c->retstack_max;
305#endif
306 PL_curpm = c->curpm;
272 PL_curcop = c->curcop; 307 PL_curcop = c->curcop;
308 PL_top_env = c->top_env;
273 309
274 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav); 310 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
275 if (c->defsv) REPLACE_SV (DEFSV , c->defsv); 311 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
276 if (c->errsv) REPLACE_SV (ERRSV , c->errsv); 312 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
277 313
… …
284 { 320 {
285 AV *padlist = (AV *)POPs; 321 AV *padlist = (AV *)POPs;
286 322
287 if (padlist) 323 if (padlist)
288 { 324 {
289 put_padlist (cv); /* mark this padlist as available */ 325 put_padlist (aTHX_ cv); /* mark this padlist as available */
290 CvPADLIST(cv) = padlist; 326 CvPADLIST(cv) = padlist;
291#ifdef USE_THREADS
292 /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
293#endif
294 } 327 }
295 328
296 ++CvDEPTH(cv); 329 ++CvDEPTH(cv);
297 } 330 }
298 331
… …
316 349
317 PUSHs (Nullsv); 350 PUSHs (Nullsv);
318 /* this loop was inspired by pp_caller */ 351 /* this loop was inspired by pp_caller */
319 for (;;) 352 for (;;)
320 { 353 {
321 do 354 while (cxix >= 0)
322 { 355 {
323 PERL_CONTEXT *cx = &ccstk[cxix--]; 356 PERL_CONTEXT *cx = &ccstk[cxix--];
324 357
325 if (CxTYPE(cx) == CXt_SUB) 358 if (CxTYPE(cx) == CXt_SUB)
326 { 359 {
327 CV *cv = cx->blk_sub.cv; 360 CV *cv = cx->blk_sub.cv;
328 if (CvDEPTH(cv)) 361 if (CvDEPTH(cv))
329 { 362 {
330#ifdef USE_THREADS
331 /*XPUSHs ((SV *)CvOWNER(cv));*/
332 /*CvOWNER(cv) = 0;*/
333 /*error must unlock this cv etc.. etc...*/
334#endif
335 EXTEND (SP, CvDEPTH(cv)*2); 363 EXTEND (SP, CvDEPTH(cv)*2);
336 364
337 while (--CvDEPTH(cv)) 365 while (--CvDEPTH(cv))
338 { 366 {
339 /* this tells the restore code to increment CvDEPTH */ 367 /* this tells the restore code to increment CvDEPTH */
… …
342 } 370 }
343 371
344 PUSHs ((SV *)CvPADLIST(cv)); 372 PUSHs ((SV *)CvPADLIST(cv));
345 PUSHs ((SV *)cv); 373 PUSHs ((SV *)cv);
346 374
347 get_padlist (cv); /* this is a monster */ 375 get_padlist (aTHX_ cv);
348 } 376 }
349 } 377 }
378#ifdef CXt_FORMAT
350 else if (CxTYPE(cx) == CXt_FORMAT) 379 else if (CxTYPE(cx) == CXt_FORMAT)
351 { 380 {
352 /* I never used formats, so how should I know how these are implemented? */ 381 /* I never used formats, so how should I know how these are implemented? */
353 /* my bold guess is as a simple, plain sub... */ 382 /* my bold guess is as a simple, plain sub... */
354 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 383 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
355 } 384 }
385#endif
356 } 386 }
357 while (cxix >= 0);
358 387
359 if (top_si->si_type == PERLSI_MAIN) 388 if (top_si->si_type == PERLSI_MAIN)
360 break; 389 break;
361 390
362 top_si = top_si->si_prev; 391 top_si = top_si->si_prev;
… …
369 398
370 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0; 399 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
371 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0; 400 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
372 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0; 401 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
373 402
374 /* I have not the slightest idea of why av_reify is necessary */
375 /* but if it's missing the defav contents magically get replaced sometimes */
376 if (c->defav)
377 av_reify (c->defav);
378
379 c->dowarn = PL_dowarn; 403 c->dowarn = PL_dowarn;
404 c->in_eval = PL_in_eval;
380 405
381 c->curstackinfo = PL_curstackinfo; 406 c->curstackinfo = PL_curstackinfo;
382 c->curstack = PL_curstack; 407 c->curstack = PL_curstack;
383 c->mainstack = PL_mainstack; 408 c->mainstack = PL_mainstack;
384 c->stack_sp = PL_stack_sp; 409 c->stack_sp = PL_stack_sp;
385 c->op = PL_op; 410 c->op = PL_op;
386 c->curpad = PL_curpad; 411 c->curpad = PL_curpad;
412 c->comppad = PL_comppad;
413 c->compcv = PL_compcv;
387 c->stack_base = PL_stack_base; 414 c->stack_base = PL_stack_base;
388 c->stack_max = PL_stack_max; 415 c->stack_max = PL_stack_max;
389 c->tmps_stack = PL_tmps_stack; 416 c->tmps_stack = PL_tmps_stack;
390 c->tmps_floor = PL_tmps_floor; 417 c->tmps_floor = PL_tmps_floor;
391 c->tmps_ix = PL_tmps_ix; 418 c->tmps_ix = PL_tmps_ix;
… …
397 c->scopestack_ix = PL_scopestack_ix; 424 c->scopestack_ix = PL_scopestack_ix;
398 c->scopestack_max = PL_scopestack_max; 425 c->scopestack_max = PL_scopestack_max;
399 c->savestack = PL_savestack; 426 c->savestack = PL_savestack;
400 c->savestack_ix = PL_savestack_ix; 427 c->savestack_ix = PL_savestack_ix;
401 c->savestack_max = PL_savestack_max; 428 c->savestack_max = PL_savestack_max;
429#if PERL_VERSION < 9
402 c->retstack = PL_retstack; 430 c->retstack = PL_retstack;
403 c->retstack_ix = PL_retstack_ix; 431 c->retstack_ix = PL_retstack_ix;
404 c->retstack_max = PL_retstack_max; 432 c->retstack_max = PL_retstack_max;
433#endif
434 c->curpm = PL_curpm;
405 c->curcop = PL_curcop; 435 c->curcop = PL_curcop;
436 c->top_env = PL_top_env;
437}
438
439/*
440 * allocate various perl stacks. This is an exact copy
441 * of perl.c:init_stacks, except that it uses less memory
442 * on the (sometimes correct) assumption that coroutines do
443 * not usually need a lot of stackspace.
444 */
445static void
446coro_init_stacks (pTHX)
447{
448 LOCK;
449
450 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
451 PL_curstackinfo->si_type = PERLSI_MAIN;
452 PL_curstack = PL_curstackinfo->si_stack;
453 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
454
455 PL_stack_base = AvARRAY(PL_curstack);
456 PL_stack_sp = PL_stack_base;
457 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
458
459 New(50,PL_tmps_stack,96,SV*);
460 PL_tmps_floor = -1;
461 PL_tmps_ix = -1;
462 PL_tmps_max = 96;
463
464 New(54,PL_markstack,16,I32);
465 PL_markstack_ptr = PL_markstack;
466 PL_markstack_max = PL_markstack + 16;
467
468#ifdef SET_MARK_OFFSET
469 SET_MARK_OFFSET;
470#endif
471
472 New(54,PL_scopestack,16,I32);
473 PL_scopestack_ix = 0;
474 PL_scopestack_max = 16;
475
476 New(54,PL_savestack,96,ANY);
477 PL_savestack_ix = 0;
478 PL_savestack_max = 96;
479
480#if PERL_VERSION < 9
481 New(54,PL_retstack,8,OP*);
482 PL_retstack_ix = 0;
483 PL_retstack_max = 8;
484#endif
485
486 UNLOCK;
406} 487}
407 488
408/* 489/*
409 * destroy the stacks, the callchain etc... 490 * destroy the stacks, the callchain etc...
410 * still there is a memleak of 128 bytes...
411 */ 491 */
412STATIC void 492static void
413destroy_stacks(pTHX) 493destroy_stacks(pTHX)
414{ 494{
495 if (!IN_DESTRUCT)
496 {
415 /* is this ugly, I ask? */ 497 /* is this ugly, I ask? */
416 while (PL_scopestack_ix) 498 LEAVE_SCOPE (0);
417 LEAVE;
418 499
419 /* sure it is, but more important: is it correct?? :/ */ 500 /* sure it is, but more important: is it correct?? :/ */
420 while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
421 FREETMPS; 501 FREETMPS;
502
503 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
504 }
422 505
423 while (PL_curstackinfo->si_next) 506 while (PL_curstackinfo->si_next)
424 PL_curstackinfo = PL_curstackinfo->si_next; 507 PL_curstackinfo = PL_curstackinfo->si_next;
425 508
426 while (PL_curstackinfo) 509 while (PL_curstackinfo)
427 { 510 {
428 PERL_SI *p = PL_curstackinfo->si_prev; 511 PERL_SI *p = PL_curstackinfo->si_prev;
429 512
430 { 513 { /*D*//*remove*/
431 dSP; 514 dSP;
432 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack); 515 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
433 PUTBACK; /* possibly superfluous */ 516 PUTBACK; /* possibly superfluous */
434 } 517 }
435 518
436 dounwind(-1); 519 if (!IN_DESTRUCT)
437 520 {
521 dounwind (-1);/*D*//*remove*/
438 SvREFCNT_dec(PL_curstackinfo->si_stack); 522 SvREFCNT_dec (PL_curstackinfo->si_stack);
523 }
524
439 Safefree(PL_curstackinfo->si_cxstack); 525 Safefree (PL_curstackinfo->si_cxstack);
440 Safefree(PL_curstackinfo); 526 Safefree (PL_curstackinfo);
441 PL_curstackinfo = p; 527 PL_curstackinfo = p;
442 } 528 }
443 529
444 Safefree(PL_tmps_stack); 530 Safefree (PL_tmps_stack);
445 Safefree(PL_markstack); 531 Safefree (PL_markstack);
446 Safefree(PL_scopestack); 532 Safefree (PL_scopestack);
447 Safefree(PL_savestack); 533 Safefree (PL_savestack);
534#if PERL_VERSION < 9
448 Safefree(PL_retstack); 535 Safefree (PL_retstack);
536#endif
449} 537}
450 538
451STATIC void 539static void
452transfer(pTHX_ struct coro *prev, struct coro *next, int flags) 540allocate_stack (Coro__State ctx, int alloc)
453{ 541{
542 coro_stack *stack;
543
544 New (0, stack, 1, coro_stack);
545
546 stack->refcnt = 1;
547 stack->usecnt = 1;
548 stack->gencnt = ctx->gencnt = 0;
549
550 if (alloc)
551 {
552#if HAVE_MMAP
553 stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; /* mmap should do allocate-on-write for us */
554 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
555 if (stack->sptr != (void *)-1)
556 {
557# if STACKGUARD
558 mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
559# endif
560 }
561 else
562#endif
563 {
564 stack->ssize = - (STACKSIZE * (long)sizeof (long));
565 New (0, stack->sptr, STACKSIZE, long);
566 }
567 }
568 else
569 stack->sptr = 0;
570
571 ctx->stack = stack;
572}
573
574static void
575deallocate_stack (Coro__State ctx)
576{
577 coro_stack *stack = ctx->stack;
578
579 ctx->stack = 0;
580
581 if (stack)
582 {
583 if (!--stack->refcnt)
584 {
585#ifdef HAVE_MMAP
586 if (stack->ssize > 0 && stack->sptr)
587 munmap (stack->sptr, stack->ssize);
588 else
589#endif
590 Safefree (stack->sptr);
591
592 Safefree (stack);
593 }
594 else if (ctx->gencnt == stack->gencnt)
595 --stack->usecnt;
596 }
597}
598
599static void
600setup_coro (void *arg)
601{
602 /*
603 * emulate part of the perl startup here.
604 */
605 dTHX;
454 dSP; 606 dSP;
607 Coro__State ctx = (Coro__State)arg;
608 SV *sub_init = (SV *)get_cv (SUB_INIT, FALSE);
609
610 coro_init_stacks (aTHX);
611 /*PL_curcop = 0;*/
612 /*PL_in_eval = PL_in_eval;*/ /* inherit */
613 SvREFCNT_dec (GvAV (PL_defgv));
614 GvAV (PL_defgv) = ctx->args; ctx->args = 0;
615
616 SPAGAIN;
617
618 if (ctx->stack)
619 {
620 ctx->cursp = 0;
621
622 PUSHMARK(SP);
623 PUTBACK;
624 (void) call_sv (sub_init, G_VOID|G_NOARGS|G_EVAL);
625
626 if (SvTRUE (ERRSV))
627 croak (NULL);
628 else
629 croak ("FATAL: CCTXT coroutine returned!");
630 }
631 else
632 {
633 UNOP myop;
634
635 Zero(&myop, 1, UNOP);
636 myop.op_next = Nullop;
637 myop.op_flags = OPf_WANT_VOID;
638
639 PL_op = (OP *)&myop;
640
641 PUSHMARK(SP);
642 XPUSHs (sub_init);
643 /*
644 * the next line is slightly wrong, as PL_op->op_next
645 * is actually being executed so we skip the first op.
646 * that doesn't matter, though, since it is only
647 * pp_nextstate and we never return...
648 * ah yes, and I don't care anyways ;)
649 */
650 PUTBACK;
651 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
652 SPAGAIN;
653
654 ENTER; /* necessary e.g. for dounwind */
655 }
656}
657
658static void
659continue_coro (void *arg)
660{
661 /*
662 * this is a _very_ stripped down perl interpreter ;)
663 */
664 dTHX;
665 Coro__State ctx = (Coro__State)arg;
666
667 PL_top_env = &PL_start_env;
668
669 ctx->cursp = 0;
670 PL_op = PL_op->op_next;
671 CALLRUNOPS(aTHX);
672
673 abort ();
674}
675
676/* never call directly, always through the coro_state_transfer global variable */
677static void
678transfer_impl (pTHX_ struct coro *prev, struct coro *next, int flags)
679{
680 dSTACKLEVEL;
455 681
456 if (prev != next) 682 if (prev != next)
457 { 683 {
458 /* 684 /* has this coro been created yet? */
459 * this could be done in newprocess which would lead to
460 * extremely elegant and fast (just SAVE/LOAD)
461 * code here, but lazy allocation of stacks has also
462 * some virtues and the overhead of the if() is nil.
463 */
464 if (next->mainstack) 685 if (next->mainstack)
465 { 686 {
687 LOCK;
466 SAVE (prev, flags); 688 SAVE (prev, flags);
467 LOAD (next); 689 LOAD (next);
690 UNLOCK;
691
468 /* mark this state as in-use */ 692 /* mark this state as in-use */
469 next->mainstack = 0; 693 next->mainstack = 0;
470 next->tmps_ix = -2; 694 next->tmps_ix = -2;
695
696 /* stacklevel changed? if yes, grab the stack for us! */
697 if (flags & TRANSFER_SAVE_CCTXT)
698 {
699 if (!prev->stack)
700 allocate_stack (prev, 0);
701 else if (prev->cursp != stacklevel
702 && prev->stack->usecnt > 1)
703 {
704 prev->gencnt = ++prev->stack->gencnt;
705 prev->stack->usecnt = 1;
706 }
707
708 /* has our stack been invalidated? */
709 if (next->stack && next->stack->gencnt != next->gencnt)
710 {
711 deallocate_stack (next);
712 allocate_stack (next, 1);
713 coro_create (&(next->stack->cctx),
714 continue_coro, (void *)next,
715 next->stack->sptr, labs (next->stack->ssize));
716 }
717
718 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
719 prev->cursp = stacklevel;
720 /* don't add any code here */
721 }
722 else
723 next->cursp = stacklevel;
471 } 724 }
472 else if (next->tmps_ix == -2) 725 else if (next->tmps_ix == -2)
473 {
474 croak ("tried to transfer to running coroutine"); 726 croak ("tried to transfer to running coroutine");
475 }
476 else 727 else
477 { 728 {
478 /* 729 LOCK;
479 * emulate part of the perl startup here.
480 */
481 UNOP myop;
482
483 SAVE (prev, -1); /* first get rid of the old state */ 730 SAVE (prev, -1); /* first get rid of the old state */
731 UNLOCK;
484 732
485 init_stacks (); /* from perl.c */ 733 /* create the coroutine for the first time */
486 SPAGAIN; 734 if (flags & TRANSFER_SAVE_CCTXT)
487
488 PL_op = (OP *)&myop;
489 /*PL_curcop = 0;*/
490 SvREFCNT_dec (GvAV (PL_defgv));
491 GvAV (PL_defgv) = next->args;
492
493 Zero(&myop, 1, UNOP);
494 myop.op_next = Nullop;
495 myop.op_flags = OPf_WANT_VOID;
496
497 PUSHMARK(SP);
498 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
499 /*
500 * the next line is slightly wrong, as PL_op->op_next
501 * is actually being executed so we skip the first op.
502 * that doesn't matter, though, since it is only
503 * pp_nextstate and we never return...
504 * ah yes, and I don't care anyways ;)
505 */ 735 {
506 PUTBACK; 736 if (!prev->stack)
507 PL_op = pp_entersub(aTHX); 737 allocate_stack (prev, 0);
508 SPAGAIN;
509 738
510 ENTER; /* necessary e.g. for dounwind */ 739 /* the new coroutine starts with start_env again */
740 PL_top_env = &PL_start_env;
741
742 if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
743 {
744 setup_coro (next);
745 next->cursp = stacklevel;
746
747 prev->stack->refcnt++;
748 prev->stack->usecnt++;
749 next->stack = prev->stack;
750 next->gencnt = prev->gencnt;
751 }
752 else
753 {
754 assert (!next->stack);
755 allocate_stack (next, 1);
756 coro_create (&(next->stack->cctx),
757 setup_coro, (void *)next,
758 next->stack->sptr, labs (next->stack->ssize));
759 coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
760 prev->cursp = stacklevel;
761 /* don't add any code here */
762 }
763 }
764 else
765 {
766 setup_coro (next);
767 next->cursp = stacklevel;
768 }
511 } 769 }
512 } 770 }
771
772 LOCK;
773 if (coro_mortal)
774 {
775 SvREFCNT_dec (coro_mortal);
776 coro_mortal = 0;
777 }
778 UNLOCK;
779}
780
781/* use this function pointer to call the above function */
782/* this is done to increase chances of the compiler not inlining the call */
783void (*coro_state_transfer)(pTHX_ struct coro *prev, struct coro *next, int flags) = transfer_impl;
784
785#define SV_CORO(sv,func) \
786 do { \
787 if (SvROK (sv)) \
788 sv = SvRV (sv); \
789 \
790 if (SvTYPE (sv) == SVt_PVHV && SvSTASH (sv) != coro_state_stash) \
791 { \
792 HE *he = hv_fetch_ent ((HV *)sv, ucoro_state_sv, 0, ucoro_state_hash); \
793 \
794 if (!he) \
795 croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
796 \
797 (sv) = SvRV (HeVAL(he)); \
798 } \
799 \
800 /* must also be changed inside Coro::Cont::yield */ \
801 if (!SvOBJECT (sv) || SvSTASH (sv) != coro_state_stash) \
802 croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
803 \
804 } while(0)
805
806static void
807coro_state_destroy (struct coro *coro)
808{
809 if (coro->refcnt--)
810 return;
811
812 if (coro->mainstack && coro->mainstack != main_mainstack)
813 {
814 struct coro temp;
815
816 SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL);
817 LOAD (aTHX_ coro);
818
819 destroy_stacks (aTHX);
820
821 LOAD ((&temp)); /* this will get rid of defsv etc.. */
822
823 coro->mainstack = 0;
824 }
825
826 deallocate_stack (coro);
827 SvREFCNT_dec (coro->args);
828 Safefree (coro);
829}
830
831static int
832coro_state_clear (SV *sv, MAGIC *mg)
833{
834 struct coro *coro = (struct coro *)mg->mg_ptr;
835 mg->mg_ptr = 0;
836
837 coro_state_destroy (coro);
838
839 return 0;
840}
841
842static int
843coro_state_dup (MAGIC *mg, CLONE_PARAMS *params)
844{
845 struct coro *coro = (struct coro *)mg->mg_ptr;
846
847 ++coro->refcnt;
848
849 return 0;
850}
851
852static MGVTBL coro_state_vtbl = { 0, 0, 0, 0, coro_state_clear, 0, coro_state_dup, 0 };
853
854static struct coro *
855SvSTATE (SV *coro)
856{
857 MAGIC *mg = SvMAGIC (SvROK (coro) ? SvRV (coro) : coro);
858 assert (mg->mg_type == PERL_MAGIC_ext);
859 return (struct coro *)mg->mg_ptr;
860}
861
862static void
863api_transfer (pTHX_ SV *prev, SV *next, int flags)
864{
865 SV_CORO (prev, "Coro::transfer");
866 SV_CORO (next, "Coro::transfer");
867
868 coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
869}
870
871/** Coro ********************************************************************/
872
873#define PRIO_MAX 3
874#define PRIO_HIGH 1
875#define PRIO_NORMAL 0
876#define PRIO_LOW -1
877#define PRIO_IDLE -3
878#define PRIO_MIN -4
879
880/* for Coro.pm */
881static GV *coro_current, *coro_idle;
882static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
883static int coro_nready;
884
885static void
886coro_enq (pTHX_ SV *sv)
887{
888 int prio;
889
890 if (SvTYPE (sv) != SVt_PVHV)
891 croak ("Coro::ready tried to enqueue something that is not a coroutine");
892
893 {
894 SV *coro = sv;
895 SV_CORO (coro, "omg");
896 prio = SvSTATE (coro)->prio;
897 }
898
899 av_push (coro_ready [prio - PRIO_MIN], sv);
900 coro_nready++;
901}
902
903static SV *
904coro_deq (pTHX_ int min_prio)
905{
906 int prio = PRIO_MAX - PRIO_MIN;
907
908 min_prio -= PRIO_MIN;
909 if (min_prio < 0)
910 min_prio = 0;
911
912 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
913 if (AvFILLp (coro_ready [prio]) >= 0)
914 {
915 coro_nready--;
916 return av_shift (coro_ready [prio]);
917 }
918
919 return 0;
920}
921
922static void
923api_ready (SV *coro)
924{
925 dTHX;
926
927 if (SvROK (coro))
928 coro = SvRV (coro);
929
930 LOCK;
931 coro_enq (aTHX_ SvREFCNT_inc (coro));
932 UNLOCK;
933}
934
935static void
936api_schedule (void)
937{
938 dTHX;
939
940 SV *prev, *next;
941
942 LOCK;
943
944 prev = SvRV (GvSV (coro_current));
945 next = coro_deq (aTHX_ PRIO_MIN);
946
947 if (!next)
948 next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
949
950 /* free this only after the transfer */
951 coro_mortal = prev;
952 SV_CORO (prev, "Coro::schedule");
953
954 SvRV (GvSV (coro_current)) = next;
955
956 SV_CORO (next, "Coro::schedule");
957
958 UNLOCK;
959
960 coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
961 TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK);
962}
963
964static void
965api_cede (void)
966{
967 dTHX;
968
969 LOCK;
970 coro_enq (aTHX_ SvREFCNT_inc (SvRV (GvSV (coro_current))));
971 UNLOCK;
972
973 api_schedule ();
513} 974}
514 975
515MODULE = Coro::State PACKAGE = Coro::State 976MODULE = Coro::State PACKAGE = Coro::State
516 977
517PROTOTYPES: ENABLE 978PROTOTYPES: DISABLE
518 979
519BOOT: 980BOOT:
520{ /* {} necessary for stoopid perl-5.6.x */ 981{ /* {} necessary for stoopid perl-5.6.x */
982#ifdef USE_ITHREADS
983 MUTEX_INIT (&coro_mutex);
984#endif
985 BOOT_PAGESIZE;
986
987 ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
988 PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
521 HV * stash = gv_stashpvn("Coro::State", 10, TRUE); 989 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
522 990
523 newCONSTSUB (stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV)); 991 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
524 newCONSTSUB (stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV)); 992 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
525 newCONSTSUB (stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV)); 993 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
526 994 newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
527 if (!padlist_cache)
528 padlist_cache = newHV ();
529 995
530 main_mainstack = PL_mainstack; 996 main_mainstack = PL_mainstack;
531}
532 997
533Coro::State 998 coroapi.ver = CORO_API_VERSION;
534_newprocess(args) 999 coroapi.transfer = api_transfer;
535 SV * args 1000
536 PROTOTYPE: $ 1001 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1002}
1003
1004SV *
1005new (char *klass, ...)
537 CODE: 1006 CODE:
538 Coro__State coro; 1007{
1008 struct coro *coro;
1009 HV *hv;
1010 int i;
539 1011
540 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
541 croak ("Coro::State::_newprocess expects an arrayref");
542
543 New (0, coro, 1, struct coro); 1012 Newz (0, coro, 1, struct coro);
1013 coro->args = newAV ();
544 1014
1015 for (i = 1; i < items; i++)
1016 av_push (coro->args, newSVsv (ST (i)));
1017
545 coro->mainstack = 0; /* actual work is done inside transfer */ 1018 /*coro->mainstack = 0; *//*actual work is done inside transfer */
546 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1019 /*coro->stack = 0;*/
547 1020
548 RETVAL = coro; 1021 hv = newHV ();
1022 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1023 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1024}
549 OUTPUT: 1025 OUTPUT:
550 RETVAL 1026 RETVAL
551 1027
552void 1028void
553transfer(prev, next, flags = TRANSFER_SAVE_ALL) 1029transfer(prev, next, flags)
554 Coro::State_or_hashref prev 1030 SV *prev
555 Coro::State_or_hashref next 1031 SV *next
556 int flags 1032 int flags
557 PROTOTYPE: @
558 CODE: 1033 CODE:
1034 PUTBACK;
1035 SV_CORO (next, "Coro::transfer");
1036 SV_CORO (prev, "Coro::transfer");
1037 coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
1038 SPAGAIN;
559 1039
560 transfer (aTHX_ prev, next, flags); 1040int
1041prio (Coro::State coro, int newprio = 0)
1042 ALIAS:
1043 nice = 1
1044 CODE:
1045{
1046 RETVAL = coro->prio;
1047
1048 if (items > 1)
1049 {
1050 if (ix)
1051 newprio += coro->prio;
1052
1053 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1054 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1055
1056 coro->prio = newprio;
1057 }
1058}
561 1059
562void 1060void
563DESTROY(coro) 1061_clone_state_from (SV *dst, SV *src)
564 Coro::State coro 1062 CODE:
565 CODE: 1063{
1064 struct coro *coro_src = SvSTATE (src);
566 1065
567 if (coro->mainstack && coro->mainstack != main_mainstack) 1066 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
568 {
569 struct coro temp;
570 1067
571 SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL); 1068 ++coro_src->refcnt;
572 LOAD(aTHX_ coro); 1069 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1070}
573 1071
574 destroy_stacks ();
575
576 LOAD((&temp)); /* this will get rid of defsv etc.. */
577 }
578
579 Safefree (coro);
580
581 /*
582 * there is one problematic case left (remember _recurse?)
583 * consider the case when we
584 *
585 * 1. start a coroutine
586 * 2. inside it descend into some xs functions
587 * 3. xs function calls a callback
588 * 4. callback switches to $main
589 * 5. $main ends - we will end inside the xs function
590 * 6. xs function returns and perl executes - what?
591 *
592 * to avoid this case we recurse in this function
593 * and simply call my_exit(0), skipping other xs functions
594 */
595
596#if 0
597void 1072void
598_recurse() 1073_exit (code)
1074 int code
1075 PROTOTYPE: $
599 CODE: 1076 CODE:
600 LEAVE; 1077 _exit (code);
601 PL_stack_sp = PL_stack_base + ax - 1;
602 PL_op = PL_op->op_next;
603 CALLRUNOPS(aTHX);
604 printf ("my_exit\n");
605 my_exit (0);
606 1078
607#endif 1079MODULE = Coro::State PACKAGE = Coro::Cont
608 1080
609void 1081void
610flush() 1082yield (...)
611 CODE:
612#ifdef MAY_FLUSH
613 flush_padlist_cache ();
614#endif
615
616MODULE = Coro::State PACKAGE = Coro::Cont
617
618# this is dirty (do you hear me?) and should be in it's own .xs
619
620void
621result(...)
622 PROTOTYPE: @ 1083 PROTOTYPE: @
623 CODE: 1084 CODE:
624 static SV *returnstk; 1085 SV *yieldstack;
625 SV *sv; 1086 SV *sv;
626 AV *defav = GvAV (PL_defgv); 1087 AV *defav = GvAV (PL_defgv);
627 struct coro *prev, *next; 1088 struct coro *prev, *next;
628 1089
629 if (!returnstk) 1090 yieldstack = *hv_fetch (
630 returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE)); 1091 (HV *)SvRV (GvSV (coro_current)),
1092 "yieldstack", sizeof ("yieldstack") - 1,
1093 0
1094 );
631 1095
632 /* set up @_ -- ugly */ 1096 /* set up @_ -- ugly */
633 av_clear (defav); 1097 av_clear (defav);
634 av_fill (defav, items - 1); 1098 av_fill (defav, items - 1);
635 while (items--) 1099 while (items--)
636 av_store (defav, items, SvREFCNT_inc (ST(items))); 1100 av_store (defav, items, SvREFCNT_inc (ST(items)));
637 1101
638 mg_get (returnstk); /* isn't documentation wrong for mg_get? */
639 sv = av_pop ((AV *)SvRV (returnstk)); 1102 sv = av_pop ((AV *)SvRV (yieldstack));
640 prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0))); 1103 prev = SvSTATE ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
641 next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0))); 1104 next = SvSTATE ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
642 SvREFCNT_dec (sv); 1105 SvREFCNT_dec (sv);
1106
643 transfer(prev, next, 0); 1107 coro_state_transfer (aTHX_ prev, next, 0);
644 1108
1109MODULE = Coro::State PACKAGE = Coro
1110
1111BOOT:
1112{
1113 int i;
1114 HV *stash = gv_stashpv ("Coro", TRUE);
1115
1116 newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
1117 newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1118 newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1119 newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
1120 newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1121 newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
1122
1123 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1124 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1125
1126 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1127 coro_ready[i] = newAV ();
1128
1129 {
1130 SV *sv = perl_get_sv("Coro::API", 1);
1131
1132 coroapi.schedule = api_schedule;
1133 coroapi.cede = api_cede;
1134 coroapi.ready = api_ready;
1135 coroapi.nready = &coro_nready;
1136 coroapi.current = coro_current;
1137
1138 GCoroAPI = &coroapi;
1139 sv_setiv (sv, (IV)&coroapi);
1140 SvREADONLY_on (sv);
1141 }
1142}
1143
1144#if !PERL_MICRO
1145
1146void
1147ready (self)
1148 SV * self
1149 PROTOTYPE: $
1150 CODE:
1151 api_ready (self);
1152
1153#endif
1154
1155int
1156nready (...)
1157 PROTOTYPE:
1158 CODE:
1159 RETVAL = coro_nready;
1160 OUTPUT:
1161 RETVAL
1162
1163void
1164schedule (...)
1165 PROTOTYPE:
1166 CODE:
1167 api_schedule ();
1168
1169void
1170cede (...)
1171 PROTOTYPE:
1172 CODE:
1173 api_cede ();
1174
1175# and these are hacks
1176SV *
1177_aio_get_state ()
1178 CODE:
1179{
1180 struct {
1181 int errorno;
1182 int laststype;
1183 int laststatval;
1184 Stat_t statcache;
1185 } data;
1186
1187 data.errorno = errno;
1188 data.laststype = PL_laststype;
1189 data.laststatval = PL_laststatval;
1190 data.statcache = PL_statcache;
1191
1192 RETVAL = newSVpvn ((char *)&data, sizeof data);
1193}
1194 OUTPUT:
1195 RETVAL
1196
1197void
1198_aio_set_state (char *data_)
1199 PROTOTYPE: $
1200 CODE:
1201{
1202 struct {
1203 int errorno;
1204 int laststype;
1205 int laststatval;
1206 Stat_t statcache;
1207 } *data = (void *)data_;
1208
1209 errno = data->errorno;
1210 PL_laststype = data->laststype;
1211 PL_laststatval = data->laststatval;
1212 PL_statcache = data->statcache;
1213}

Diff Legend

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