1 | #define PERL_NO_GET_CONTEXT |
|
|
2 | |
|
|
3 | #include "libcoro/coro.c" |
1 | #include "libcoro/coro.c" |
4 | |
2 | |
5 | #include "EXTERN.h" |
3 | #include "EXTERN.h" |
6 | #include "perl.h" |
4 | #include "perl.h" |
7 | #include "XSUB.h" |
5 | #include "XSUB.h" |
… | |
… | |
154 | |
152 | |
155 | typedef struct coro *Coro__State; |
153 | typedef struct coro *Coro__State; |
156 | typedef struct coro *Coro__State_or_hashref; |
154 | typedef struct coro *Coro__State_or_hashref; |
157 | |
155 | |
158 | static AV * |
156 | static AV * |
159 | coro_clone_padlist (pTHX_ CV *cv) |
157 | coro_clone_padlist (CV *cv) |
160 | { |
158 | { |
161 | AV *padlist = CvPADLIST (cv); |
159 | AV *padlist = CvPADLIST (cv); |
162 | AV *newpadlist, *newpad; |
160 | AV *newpadlist, *newpad; |
163 | |
161 | |
164 | newpadlist = newAV (); |
162 | newpadlist = newAV (); |
… | |
… | |
176 | |
174 | |
177 | return newpadlist; |
175 | return newpadlist; |
178 | } |
176 | } |
179 | |
177 | |
180 | static void |
178 | static void |
181 | free_padlist (pTHX_ AV *padlist) |
179 | free_padlist (AV *padlist) |
182 | { |
180 | { |
183 | /* may be during global destruction */ |
181 | /* may be during global destruction */ |
184 | if (SvREFCNT (padlist)) |
182 | if (SvREFCNT (padlist)) |
185 | { |
183 | { |
186 | I32 i = AvFILLp (padlist); |
184 | I32 i = AvFILLp (padlist); |
… | |
… | |
207 | AV *padlist; |
205 | AV *padlist; |
208 | AV *av = (AV *)mg->mg_obj; |
206 | AV *av = (AV *)mg->mg_obj; |
209 | |
207 | |
210 | /* casting is fun. */ |
208 | /* casting is fun. */ |
211 | while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) |
209 | while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) |
212 | free_padlist (aTHX_ padlist); |
210 | free_padlist (padlist); |
213 | |
211 | |
214 | SvREFCNT_dec (av); |
212 | SvREFCNT_dec (av); |
215 | |
213 | |
216 | return 0; |
214 | return 0; |
217 | } |
215 | } |
… | |
… | |
220 | |
218 | |
221 | static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free}; |
219 | static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free}; |
222 | |
220 | |
223 | /* the next two functions merely cache the padlists */ |
221 | /* the next two functions merely cache the padlists */ |
224 | static void |
222 | static void |
225 | get_padlist (pTHX_ CV *cv) |
223 | get_padlist (CV *cv) |
226 | { |
224 | { |
227 | MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); |
225 | MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); |
228 | |
226 | |
229 | if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0) |
227 | if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0) |
230 | CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj); |
228 | CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj); |
231 | else |
229 | else |
232 | { |
230 | { |
233 | #if 0 |
231 | #if 0 |
234 | /* this is probably cleaner, but also slower? */ |
232 | /* this is probably cleaner, but also slower? */ |
235 | CV *cp = Perl_cv_clone (aTHX_ cv); |
233 | CV *cp = Perl_cv_clone (cv); |
236 | CvPADLIST (cv) = CvPADLIST (cp); |
234 | CvPADLIST (cv) = CvPADLIST (cp); |
237 | CvPADLIST (cp) = 0; |
235 | CvPADLIST (cp) = 0; |
238 | SvREFCNT_dec (cp); |
236 | SvREFCNT_dec (cp); |
239 | #else |
237 | #else |
240 | CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv); |
238 | CvPADLIST (cv) = coro_clone_padlist (cv); |
241 | #endif |
239 | #endif |
242 | } |
240 | } |
243 | } |
241 | } |
244 | |
242 | |
245 | static void |
243 | static void |
246 | put_padlist (pTHX_ CV *cv) |
244 | put_padlist (CV *cv) |
247 | { |
245 | { |
248 | MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); |
246 | MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro); |
249 | |
247 | |
250 | if (!mg) |
248 | if (!mg) |
251 | { |
249 | { |
… | |
… | |
259 | } |
257 | } |
260 | |
258 | |
261 | #define SB do { |
259 | #define SB do { |
262 | #define SE } while (0) |
260 | #define SE } while (0) |
263 | |
261 | |
264 | #define LOAD(state) load_state(aTHX_ (state)); |
262 | #define LOAD(state) load_state((state)); |
265 | #define SAVE(state,flags) save_state(aTHX_ (state),(flags)); |
263 | #define SAVE(state,flags) save_state((state),(flags)); |
266 | |
264 | |
267 | #define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE |
265 | #define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE |
268 | |
266 | |
269 | static void |
267 | static void |
270 | load_state(pTHX_ Coro__State c) |
268 | load_state(Coro__State c) |
271 | { |
269 | { |
272 | PL_dowarn = c->dowarn; |
270 | PL_dowarn = c->dowarn; |
273 | PL_in_eval = c->in_eval; |
271 | PL_in_eval = c->in_eval; |
274 | |
272 | |
275 | PL_curstackinfo = c->curstackinfo; |
273 | PL_curstackinfo = c->curstackinfo; |
… | |
… | |
316 | { |
314 | { |
317 | AV *padlist = (AV *)POPs; |
315 | AV *padlist = (AV *)POPs; |
318 | |
316 | |
319 | if (padlist) |
317 | if (padlist) |
320 | { |
318 | { |
321 | put_padlist (aTHX_ cv); /* mark this padlist as available */ |
319 | put_padlist (cv); /* mark this padlist as available */ |
322 | CvPADLIST(cv) = padlist; |
320 | CvPADLIST(cv) = padlist; |
323 | } |
321 | } |
324 | |
322 | |
325 | ++CvDEPTH(cv); |
323 | ++CvDEPTH(cv); |
326 | } |
324 | } |
… | |
… | |
328 | PUTBACK; |
326 | PUTBACK; |
329 | } |
327 | } |
330 | } |
328 | } |
331 | |
329 | |
332 | static void |
330 | static void |
333 | save_state(pTHX_ Coro__State c, int flags) |
331 | save_state(Coro__State c, int flags) |
334 | { |
332 | { |
335 | { |
333 | { |
336 | dSP; |
334 | dSP; |
337 | I32 cxix = cxstack_ix; |
335 | I32 cxix = cxstack_ix; |
338 | PERL_CONTEXT *ccstk = cxstack; |
336 | PERL_CONTEXT *ccstk = cxstack; |
… | |
… | |
366 | } |
364 | } |
367 | |
365 | |
368 | PUSHs ((SV *)CvPADLIST(cv)); |
366 | PUSHs ((SV *)CvPADLIST(cv)); |
369 | PUSHs ((SV *)cv); |
367 | PUSHs ((SV *)cv); |
370 | |
368 | |
371 | get_padlist (aTHX_ cv); |
369 | get_padlist (cv); |
372 | } |
370 | } |
373 | } |
371 | } |
374 | #ifdef CXt_FORMAT |
372 | #ifdef CXt_FORMAT |
375 | else if (CxTYPE(cx) == CXt_FORMAT) |
373 | else if (CxTYPE(cx) == CXt_FORMAT) |
376 | { |
374 | { |
… | |
… | |
436 | * of perl.c:init_stacks, except that it uses less memory |
434 | * of perl.c:init_stacks, except that it uses less memory |
437 | * on the (sometimes correct) assumption that coroutines do |
435 | * on the (sometimes correct) assumption that coroutines do |
438 | * not usually need a lot of stackspace. |
436 | * not usually need a lot of stackspace. |
439 | */ |
437 | */ |
440 | static void |
438 | static void |
441 | coro_init_stacks (pTHX) |
439 | coro_init_stacks () |
442 | { |
440 | { |
443 | LOCK; |
441 | LOCK; |
444 | |
442 | |
445 | PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1); |
443 | PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1); |
446 | PL_curstackinfo->si_type = PERLSI_MAIN; |
444 | PL_curstackinfo->si_type = PERLSI_MAIN; |
… | |
… | |
483 | |
481 | |
484 | /* |
482 | /* |
485 | * destroy the stacks, the callchain etc... |
483 | * destroy the stacks, the callchain etc... |
486 | */ |
484 | */ |
487 | static void |
485 | static void |
488 | destroy_stacks(pTHX) |
486 | destroy_stacks() |
489 | { |
487 | { |
490 | if (!IN_DESTRUCT) |
488 | if (!IN_DESTRUCT) |
491 | { |
489 | { |
492 | /* is this ugly, I ask? */ |
490 | /* is this ugly, I ask? */ |
493 | LEAVE_SCOPE (0); |
491 | LEAVE_SCOPE (0); |
… | |
… | |
540 | dTHX; |
538 | dTHX; |
541 | dSP; |
539 | dSP; |
542 | UNOP myop; |
540 | UNOP myop; |
543 | SV *sub_init = (SV *)get_cv ("Coro::State::coro_init", FALSE); |
541 | SV *sub_init = (SV *)get_cv ("Coro::State::coro_init", FALSE); |
544 | |
542 | |
545 | coro_init_stacks (aTHX); |
543 | coro_init_stacks (); |
546 | /*PL_curcop = 0;*/ |
544 | /*PL_curcop = 0;*/ |
547 | /*PL_in_eval = PL_in_eval;*/ /* inherit */ |
545 | /*PL_in_eval = PL_in_eval;*/ /* inherit */ |
548 | SvREFCNT_dec (GvAV (PL_defgv)); |
546 | SvREFCNT_dec (GvAV (PL_defgv)); |
549 | GvAV (PL_defgv) = coro->args; coro->args = 0; |
547 | GvAV (PL_defgv) = coro->args; coro->args = 0; |
550 | |
548 | |
… | |
… | |
568 | static void |
566 | static void |
569 | free_coro_mortal () |
567 | free_coro_mortal () |
570 | { |
568 | { |
571 | if (coro_mortal) |
569 | if (coro_mortal) |
572 | { |
570 | { |
573 | dTHX; |
|
|
574 | |
|
|
575 | SvREFCNT_dec (coro_mortal); |
571 | SvREFCNT_dec (coro_mortal); |
576 | coro_mortal = 0; |
572 | coro_mortal = 0; |
577 | } |
573 | } |
578 | } |
574 | } |
579 | |
575 | |
… | |
… | |
595 | |
591 | |
596 | /* continue at cctx_init, without entersub */ |
592 | /* continue at cctx_init, without entersub */ |
597 | PL_restartop = CvSTART (get_cv ("Coro::State::cctx_init", FALSE)); |
593 | PL_restartop = CvSTART (get_cv ("Coro::State::cctx_init", FALSE)); |
598 | |
594 | |
599 | /* somebody will hit me for both perl_run and PL_restartop */ |
595 | /* somebody will hit me for both perl_run and PL_restartop */ |
600 | ret = perl_run (aTHX_ PERL_GET_CONTEXT); |
596 | ret = perl_run (PERL_GET_CONTEXT); |
601 | printf ("ret %d\n", ret);//D |
597 | printf ("ret %d\n", ret);//D |
602 | |
598 | |
603 | fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr); |
599 | fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr); |
604 | abort (); |
600 | abort (); |
605 | } |
601 | } |
… | |
… | |
688 | stack_first = stack; |
684 | stack_first = stack; |
689 | } |
685 | } |
690 | |
686 | |
691 | /* never call directly, always through the coro_state_transfer global variable */ |
687 | /* never call directly, always through the coro_state_transfer global variable */ |
692 | static void |
688 | static void |
693 | transfer_impl (pTHX_ struct coro *prev, struct coro *next, int flags) |
689 | transfer_impl (struct coro *prev, struct coro *next, int flags) |
694 | { |
690 | { |
695 | dSTACKLEVEL; |
691 | dSTACKLEVEL; |
696 | |
692 | |
697 | /* sometimes transfer is only called to set idle_sp */ |
693 | /* sometimes transfer is only called to set idle_sp */ |
698 | if (flags == TRANSFER_SET_STACKLEVEL) |
694 | if (flags == TRANSFER_SET_STACKLEVEL) |
… | |
… | |
750 | } |
746 | } |
751 | |
747 | |
752 | /* use this function pointer to call the above function */ |
748 | /* use this function pointer to call the above function */ |
753 | /* this is done to increase chances of the compiler not inlining the call */ |
749 | /* this is done to increase chances of the compiler not inlining the call */ |
754 | /* not static to make it even harder for the compiler (and theoretically impossible in most cases */ |
750 | /* not static to make it even harder for the compiler (and theoretically impossible in most cases */ |
755 | void (*coro_state_transfer)(pTHX_ struct coro *prev, struct coro *next, int flags) = transfer_impl; |
751 | void (*coro_state_transfer)(struct coro *prev, struct coro *next, int flags) = transfer_impl; |
756 | |
752 | |
757 | struct transfer_args |
753 | struct transfer_args |
758 | { |
754 | { |
759 | struct coro *prev, *next; |
755 | struct coro *prev, *next; |
760 | int flags; |
756 | int flags; |
… | |
… | |
770 | |
766 | |
771 | if (coro->mainstack && coro->mainstack != main_mainstack) |
767 | if (coro->mainstack && coro->mainstack != main_mainstack) |
772 | { |
768 | { |
773 | struct coro temp; |
769 | struct coro temp; |
774 | |
770 | |
775 | SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL); |
771 | SAVE ((&temp), TRANSFER_SAVE_ALL); |
776 | LOAD (aTHX_ coro); |
772 | LOAD (coro); |
777 | |
773 | |
778 | destroy_stacks (aTHX); |
774 | destroy_stacks (); |
779 | |
775 | |
780 | LOAD ((&temp)); /* this will get rid of defsv etc.. */ |
776 | LOAD ((&temp)); /* this will get rid of defsv etc.. */ |
781 | |
777 | |
782 | coro->mainstack = 0; |
778 | coro->mainstack = 0; |
783 | } |
779 | } |
… | |
… | |
786 | SvREFCNT_dec (coro->args); |
782 | SvREFCNT_dec (coro->args); |
787 | Safefree (coro); |
783 | Safefree (coro); |
788 | } |
784 | } |
789 | |
785 | |
790 | static int |
786 | static int |
791 | coro_state_clear (SV *sv, MAGIC *mg) |
787 | coro_state_clear (pTHX_ SV *sv, MAGIC *mg) |
792 | { |
788 | { |
793 | struct coro *coro = (struct coro *)mg->mg_ptr; |
789 | struct coro *coro = (struct coro *)mg->mg_ptr; |
794 | mg->mg_ptr = 0; |
790 | mg->mg_ptr = 0; |
795 | |
791 | |
796 | coro_state_destroy (coro); |
792 | coro_state_destroy (coro); |
797 | |
793 | |
798 | return 0; |
794 | return 0; |
799 | } |
795 | } |
800 | |
796 | |
801 | static int |
797 | static int |
802 | coro_state_dup (MAGIC *mg, CLONE_PARAMS *params) |
798 | coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params) |
803 | { |
799 | { |
804 | struct coro *coro = (struct coro *)mg->mg_ptr; |
800 | struct coro *coro = (struct coro *)mg->mg_ptr; |
805 | |
801 | |
806 | ++coro->refcnt; |
802 | ++coro->refcnt; |
807 | |
803 | |
… | |
… | |
831 | assert (mg->mg_type == PERL_MAGIC_ext); |
827 | assert (mg->mg_type == PERL_MAGIC_ext); |
832 | return (struct coro *)mg->mg_ptr; |
828 | return (struct coro *)mg->mg_ptr; |
833 | } |
829 | } |
834 | |
830 | |
835 | static void |
831 | static void |
836 | prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev, SV *next, int flags) |
832 | prepare_transfer (struct transfer_args *ta, SV *prev, SV *next, int flags) |
837 | { |
833 | { |
838 | ta->prev = SvSTATE (prev); |
834 | ta->prev = SvSTATE (prev); |
839 | ta->next = SvSTATE (next); |
835 | ta->next = SvSTATE (next); |
840 | ta->flags = flags; |
836 | ta->flags = flags; |
841 | } |
837 | } |
… | |
… | |
844 | api_transfer (SV *prev, SV *next, int flags) |
840 | api_transfer (SV *prev, SV *next, int flags) |
845 | { |
841 | { |
846 | dTHX; |
842 | dTHX; |
847 | struct transfer_args ta; |
843 | struct transfer_args ta; |
848 | |
844 | |
849 | prepare_transfer (aTHX_ &ta, prev, next, flags); |
845 | prepare_transfer (&ta, prev, next, flags); |
850 | TRANSFER (ta); |
846 | TRANSFER (ta); |
851 | } |
847 | } |
852 | |
848 | |
853 | /** Coro ********************************************************************/ |
849 | /** Coro ********************************************************************/ |
854 | |
850 | |
… | |
… | |
863 | static GV *coro_current, *coro_idle; |
859 | static GV *coro_current, *coro_idle; |
864 | static AV *coro_ready [PRIO_MAX-PRIO_MIN+1]; |
860 | static AV *coro_ready [PRIO_MAX-PRIO_MIN+1]; |
865 | static int coro_nready; |
861 | static int coro_nready; |
866 | |
862 | |
867 | static void |
863 | static void |
868 | coro_enq (pTHX_ SV *sv) |
864 | coro_enq (SV *sv) |
869 | { |
865 | { |
870 | int prio; |
866 | int prio; |
871 | |
867 | |
872 | if (SvTYPE (sv) != SVt_PVHV) |
868 | if (SvTYPE (sv) != SVt_PVHV) |
873 | croak ("Coro::ready tried to enqueue something that is not a coroutine"); |
869 | croak ("Coro::ready tried to enqueue something that is not a coroutine"); |
… | |
… | |
877 | av_push (coro_ready [prio - PRIO_MIN], sv); |
873 | av_push (coro_ready [prio - PRIO_MIN], sv); |
878 | coro_nready++; |
874 | coro_nready++; |
879 | } |
875 | } |
880 | |
876 | |
881 | static SV * |
877 | static SV * |
882 | coro_deq (pTHX_ int min_prio) |
878 | coro_deq (int min_prio) |
883 | { |
879 | { |
884 | int prio = PRIO_MAX - PRIO_MIN; |
880 | int prio = PRIO_MAX - PRIO_MIN; |
885 | |
881 | |
886 | min_prio -= PRIO_MIN; |
882 | min_prio -= PRIO_MIN; |
887 | if (min_prio < 0) |
883 | if (min_prio < 0) |
… | |
… | |
904 | |
900 | |
905 | if (SvROK (coro)) |
901 | if (SvROK (coro)) |
906 | coro = SvRV (coro); |
902 | coro = SvRV (coro); |
907 | |
903 | |
908 | LOCK; |
904 | LOCK; |
909 | coro_enq (aTHX_ SvREFCNT_inc (coro)); |
905 | coro_enq (SvREFCNT_inc (coro)); |
910 | UNLOCK; |
906 | UNLOCK; |
911 | } |
907 | } |
912 | |
908 | |
913 | static void |
909 | static void |
914 | prepare_schedule (aTHX_ struct transfer_args *ta) |
910 | prepare_schedule (struct transfer_args *ta) |
915 | { |
911 | { |
916 | SV *current, *prev, *next; |
912 | SV *current, *prev, *next; |
917 | |
913 | |
918 | LOCK; |
914 | LOCK; |
919 | |
915 | |
… | |
… | |
921 | |
917 | |
922 | for (;;) |
918 | for (;;) |
923 | { |
919 | { |
924 | LOCK; |
920 | LOCK; |
925 | |
921 | |
926 | next = coro_deq (aTHX_ PRIO_MIN); |
922 | next = coro_deq (PRIO_MIN); |
927 | |
923 | |
928 | if (next) |
924 | if (next) |
929 | break; |
925 | break; |
930 | |
926 | |
931 | UNLOCK; |
927 | UNLOCK; |
… | |
… | |
958 | |
954 | |
959 | UNLOCK; |
955 | UNLOCK; |
960 | } |
956 | } |
961 | |
957 | |
962 | static void |
958 | static void |
963 | prepare_cede (aTHX_ struct transfer_args *ta) |
959 | prepare_cede (struct transfer_args *ta) |
964 | { |
960 | { |
965 | LOCK; |
961 | LOCK; |
966 | coro_enq (aTHX_ SvREFCNT_inc (SvRV (GvSV (coro_current)))); |
962 | coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current)))); |
967 | UNLOCK; |
963 | UNLOCK; |
968 | |
964 | |
969 | prepare_schedule (ta); |
965 | prepare_schedule (ta); |
970 | } |
966 | } |
971 | |
967 | |