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

Diff Legend

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