Coro/Coro/State.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#if 0
# define CHK(x) (void *)0
#else
# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
#endif

struct coro {
  U8 dowarn;
  AV *defav;
  
  PERL_SI *curstackinfo;
  AV *curstack;
  AV *mainstack;
  SV **stack_sp;
  OP *op;
  SV **curpad;
  SV **stack_base;
  SV **stack_max;
  SV **tmps_stack;
  I32 tmps_floor;
  I32 tmps_ix;
  I32 tmps_max;
  I32 *markstack;
  I32 *markstack_ptr;
  I32 *markstack_max;
  I32 *scopestack;
  I32 scopestack_ix;
  I32 scopestack_max;
  ANY *savestack;
  I32 savestack_ix;
  I32 savestack_max;
  OP **retstack;
  I32 retstack_ix;
  I32 retstack_max;
  COP *curcop;

  AV *args;
};

typedef struct coro *Coro__State;
typedef struct coro *Coro__State_or_hashref;

static HV *padlist_cache;

/* mostly copied from op.c:cv_clone2 */
STATIC AV *
clone_padlist (AV *protopadlist)
{
  AV *av;
  I32 ix;
  AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
  AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
  SV **pname = AvARRAY (protopad_name);
  SV **ppad = AvARRAY (protopad);
  I32 fname = AvFILLp (protopad_name);
  I32 fpad = AvFILLp (protopad);
  AV *newpadlist, *newpad_name, *newpad;
  SV **npad;

  newpad_name = newAV ();
  for (ix = fname; ix >= 0; ix--)
    av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));

  newpad = newAV ();
  av_fill (newpad, AvFILLp (protopad));
  npad = AvARRAY (newpad);

  newpadlist = newAV ();
  AvREAL_off (newpadlist);
  av_store (newpadlist, 0, (SV *) newpad_name);
  av_store (newpadlist, 1, (SV *) newpad);

  av = newAV ();                /* will be @_ */
  av_extend (av, 0);
  av_store (newpad, 0, (SV *) av);
  AvFLAGS (av) = AVf_REIFY;

  for (ix = fpad; ix > 0; ix--)
    {
      SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
      if (namesv && namesv != &PL_sv_undef)
        {
          char *name = SvPVX (namesv);        /* XXX */
          if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')
            {                        /* lexical from outside? */
              npad[ix] = SvREFCNT_inc (ppad[ix]);
            }
          else
            {                        /* our own lexical */
              SV *sv;
              if (*name == '&')
                sv = SvREFCNT_inc (ppad[ix]);
              else if (*name == '@')
                sv = (SV *) newAV ();
              else if (*name == '%')
                sv = (SV *) newHV ();
              else
                sv = NEWSV (0, 0);
              if (!SvPADBUSY (sv))
                SvPADMY_on (sv);
              npad[ix] = sv;
            }
        }
      else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
        {
          npad[ix] = SvREFCNT_inc (ppad[ix]);
        }
      else
        {
          SV *sv = NEWSV (0, 0);
          SvPADTMP_on (sv);
          npad[ix] = sv;
        }
    }

#if 0 /* NONOTUNDERSTOOD */
    /* Now that vars are all in place, clone nested closures. */

    for (ix = fpad; ix > 0; ix--) {
        SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
        if (namesv
            && namesv != &PL_sv_undef
            && !(SvFLAGS(namesv) & SVf_FAKE)
            && *SvPVX(namesv) == '&'
            && CvCLONE(ppad[ix]))
        {
            CV *kid = cv_clone((CV*)ppad[ix]);
            SvREFCNT_dec(ppad[ix]);
            CvCLONE_on(kid);
            SvPADMY_on(kid);
            npad[ix] = (SV*)kid;
        }
    }
#endif

  return newpadlist;
}

STATIC AV *
free_padlist (AV *padlist)
{
  /* may be during global destruction */
  if (SvREFCNT(padlist))
    {
      I32 i = AvFILLp(padlist);
      while (i >= 0)
        {
          SV **svp = av_fetch(padlist, i--, FALSE);
          SV *sv = svp ? *svp : Nullsv;
          if (sv)
            SvREFCNT_dec(sv);
        }

      SvREFCNT_dec((SV*)padlist);
  }
}

STATIC AV *
unuse_padlist (AV *padlist)
{
  free_padlist (padlist);
}

static void
SAVE(pTHX_ Coro__State c)
{
  {
    dSP;
    I32 cxix = cxstack_ix;
    PERL_SI *top_si = PL_curstackinfo;
    PERL_CONTEXT *ccstk = cxstack;

    /*
     * the worst thing you can imagine happens first - we have to save
     * (and reinitialize) all cv's in the whole callchain :(
     */

    PUSHs (Nullsv);
    /* this loop was inspired by pp_caller */
    for (;;)
      {
        while (cxix >= 0)
          {
            PERL_CONTEXT *cx = &ccstk[--cxix];

            if (CxTYPE(cx) == CXt_SUB)
              {
                CV *cv = cx->blk_sub.cv;
                if (CvDEPTH(cv))
                  {
#ifdef USE_THREADS
                    XPUSHs ((SV *)CvOWNER(cv));
#endif
                    EXTEND (SP, 3);
                    PUSHs ((SV *)CvDEPTH(cv));
                    PUSHs ((SV *)CvPADLIST(cv));
                    PUSHs ((SV *)cv);

                    CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));

                    CvDEPTH(cv) = 0;
#ifdef USE_THREADS
                    CvOWNER(cv) = 0;
                    error must unlock this cv etc.. etc...
                    if you are here wondering about this error message then
                    the reason is that it will not work as advertised yet
#endif
                  }
              }
            else if (CxTYPE(cx) == CXt_FORMAT)
              {
                /* I never used formats, so how should I know how these are implemented? */
                /* my bold guess is as a simple, plain sub... */
                croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
              }
          }

        if (top_si->si_type == PERLSI_MAIN)
          break;

        top_si = top_si->si_prev;
        ccstk = top_si->si_cxstack;
        cxix = top_si->si_cxix;
      }

    PUTBACK;
  }

  c->dowarn = PL_dowarn;
  c->defav = GvAV (PL_defgv);
  c->curstackinfo = PL_curstackinfo;
  c->curstack = PL_curstack;
  c->mainstack = PL_mainstack;
  c->stack_sp = PL_stack_sp;
  c->op = PL_op;
  c->curpad = PL_curpad;
  c->stack_base = PL_stack_base;
  c->stack_max = PL_stack_max;
  c->tmps_stack = PL_tmps_stack;
  c->tmps_floor = PL_tmps_floor;
  c->tmps_ix = PL_tmps_ix;
  c->tmps_max = PL_tmps_max;
  c->markstack = PL_markstack;
  c->markstack_ptr = PL_markstack_ptr;
  c->markstack_max = PL_markstack_max;
  c->scopestack = PL_scopestack;
  c->scopestack_ix = PL_scopestack_ix;
  c->scopestack_max = PL_scopestack_max;
  c->savestack = PL_savestack;
  c->savestack_ix = PL_savestack_ix;
  c->savestack_max = PL_savestack_max;
  c->retstack = PL_retstack;
  c->retstack_ix = PL_retstack_ix;
  c->retstack_max = PL_retstack_max;
  c->curcop = PL_curcop;
}

static void
LOAD(pTHX_ Coro__State c)
{
  PL_dowarn = c->dowarn;
  GvAV (PL_defgv) = c->defav;
  PL_curstackinfo = c->curstackinfo;
  PL_curstack = c->curstack;
  PL_mainstack = c->mainstack;
  PL_stack_sp = c->stack_sp;
  PL_op = c->op;
  PL_curpad = c->curpad;
  PL_stack_base = c->stack_base;
  PL_stack_max = c->stack_max;
  PL_tmps_stack = c->tmps_stack;
  PL_tmps_floor = c->tmps_floor;
  PL_tmps_ix = c->tmps_ix;
  PL_tmps_max = c->tmps_max;
  PL_markstack = c->markstack;
  PL_markstack_ptr = c->markstack_ptr;
  PL_markstack_max = c->markstack_max;
  PL_scopestack = c->scopestack;
  PL_scopestack_ix = c->scopestack_ix;
  PL_scopestack_max = c->scopestack_max;
  PL_savestack = c->savestack;
  PL_savestack_ix = c->savestack_ix;
  PL_savestack_max = c->savestack_max;
  PL_retstack = c->retstack;
  PL_retstack_ix = c->retstack_ix;
  PL_retstack_max = c->retstack_max;
  PL_curcop = c->curcop;

  {
    dSP;
    CV *cv;

    /* now do the ugly restore mess */
    while ((cv = (CV *)POPs))
      {
        AV *padlist = (AV *)POPs;

        unuse_padlist (CvPADLIST(cv));
        CvPADLIST(cv) = padlist;
        CvDEPTH(cv) = (I32)POPs;

#ifdef USE_THREADS
        CvOWNER(cv) = (struct perl_thread *)POPs;
        error does not work either
#endif
      }

    PUTBACK;
  }
}

/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
STATIC void
S_nuke_stacks(pTHX)
{
    while (PL_curstackinfo->si_next)
        PL_curstackinfo = PL_curstackinfo->si_next;
    while (PL_curstackinfo) {
        PERL_SI *p = PL_curstackinfo->si_prev;
        /* curstackinfo->si_stack got nuked by sv_free_arenas() */
        Safefree(PL_curstackinfo->si_cxstack);
        Safefree(PL_curstackinfo);
        PL_curstackinfo = p;
    }
    Safefree(PL_tmps_stack);
    Safefree(PL_markstack);
    Safefree(PL_scopestack);
    Safefree(PL_savestack);
    Safefree(PL_retstack);
}

#define SUB_INIT "Coro::State::_newcoro"

MODULE = Coro::State                PACKAGE = Coro::State

PROTOTYPES: ENABLE

BOOT:
        if (!padlist_cache)
          padlist_cache = newHV ();

Coro::State
_newprocess(args)
        SV *    args
        PROTOTYPE: $
        CODE:
        Coro__State coro;

        if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
          croak ("Coro::State::newprocess expects an arrayref");
        
        New (0, coro, 1, struct coro);

        coro->mainstack = 0; /* actual work is done inside transfer */
        coro->args = (AV *)SvREFCNT_inc (SvRV (args));

        RETVAL = coro;
        OUTPUT:
        RETVAL

void
transfer(prev,next)
        Coro::State_or_hashref  prev
        Coro::State_or_hashref  next
        CODE:

        if (prev != next)
          {
            PUTBACK;
            SAVE (aTHX_ prev);

            /*
             * this could be done in newprocess which would lead to
             * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
             * code here, but lazy allocation of stacks has also
             * some virtues and the overhead of the if() is nil.
             */
            if (next->mainstack)
              {
                LOAD (aTHX_ next);
                next->mainstack = 0; /* unnecessary but much cleaner */
                SPAGAIN;
              }
            else
              {
                /*
                 * emulate part of the perl startup here.
                 */
                UNOP myop;

                init_stacks ();
                PL_op = (OP *)&myop;
                /*PL_curcop = 0;*/
                GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);

                SPAGAIN;
                Zero(&myop, 1, UNOP);
                myop.op_next = Nullop;
                myop.op_flags = OPf_WANT_VOID;

                PUSHMARK(SP);
                XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
                PUTBACK;
                /*
                 * the next line is slightly wrong, as PL_op->op_next
                 * is actually being executed so we skip the first op.
                 * that doesn't matter, though, since it is only
                 * pp_nextstate and we never return...
                 */
                PL_op = Perl_pp_entersub(aTHX);
                SPAGAIN;

                ENTER;
              }
          }

void
DESTROY(coro)
        Coro::State     coro
        CODE:

        if (coro->mainstack)
          {
            struct coro temp;

            PUTBACK;
            SAVE(aTHX_ (&temp));
            LOAD(aTHX_ coro);

            S_nuke_stacks ();
            SvREFCNT_dec ((SV *)GvAV (PL_defgv));

            LOAD((&temp));
            SPAGAIN;
          }

        SvREFCNT_dec (coro->args);
        Safefree (coro);


Revision:	1.3
Committed:	Tue Jul 17 00:24:15 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.2:	+307 -83 lines
Log Message:	* empty log message *
#	Content
1	#include "EXTERN.h"
2	#include "perl.h"
3	#include "XSUB.h"
4
5	#if 0
6	# define CHK(x) (void *)0
7	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9	#endif
10
11	struct coro {
12	U8 dowarn;
13	AV *defav;
14
15	PERL_SI *curstackinfo;
16	AV *curstack;
17	AV *mainstack;
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
41	AV *args;
42	};
43
44	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;
46
47	static HV *padlist_cache;
48
49	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *
51	clone_padlist (AV *protopadlist)
52	{
53	AV *av;
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;
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
72	newpadlist = newAV ();
73	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);
75	av_store (newpadlist, 1, (SV *) newpad);
76
77	av = newAV (); /* will be @_ */
78	av_extend (av, 0);
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81
82	for (ix = fpad; ix > 0; ix--)
83	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
85	if (namesv && namesv != &PL_sv_undef)
86	{
87	char name = SvPVX (namesv); / XXX */
88	if (SvFLAGS (namesv) & SVf_FAKE \|\| *name == '&')
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}
92	else
93	{ /* our own lexical */
94	SV *sv;
95	if (*name == '&')
96	sv = SvREFCNT_inc (ppad[ix]);
97	else if (*name == '@')
98	sv = (SV *) newAV ();
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	}
107	}
108	else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))
109	{
110	npad[ix] = SvREFCNT_inc (ppad[ix]);
111	}
112	else
113	{
114	SV *sv = NEWSV (0, 0);
115	SvPADTMP_on (sv);
116	npad[ix] = sv;
117	}
118	}
119
120	#if 0 /* NONOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */
122
123	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv
126	&& namesv != &PL_sv_undef
127	&& !(SvFLAGS(namesv) & SVf_FAKE)
128	&& *SvPVX(namesv) == '&'
129	&& CvCLONE(ppad[ix]))
130	{
131	CV kid = cv_clone((CV)ppad[ix]);
132	SvREFCNT_dec(ppad[ix]);
133	CvCLONE_on(kid);
134	SvPADMY_on(kid);
135	npad[ix] = (SV*)kid;
136	}
137	}
138	#endif
139
140	return newpadlist;
141	}
142
143	STATIC AV *
144	free_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	}
160	}
161
162	STATIC AV *
163	unuse_padlist (AV *padlist)
164	{
165	free_padlist (padlist);
166	}
167
168	static void
169	SAVE(pTHX_ Coro__State c)
170	{
171	{
172	dSP;
173	I32 cxix = cxstack_ix;
174	PERL_SI *top_si = PL_curstackinfo;
175	PERL_CONTEXT *ccstk = cxstack;
176
177	/*
178	* the worst thing you can imagine happens first - we have to save
179	* (and reinitialize) all cv's in the whole callchain :(
180	*/
181
182	PUSHs (Nullsv);
183	/* this loop was inspired by pp_caller */
184	for (;;)
185	{
186	while (cxix >= 0)
187	{
188	PERL_CONTEXT *cx = &ccstk[--cxix];
189
190	if (CxTYPE(cx) == CXt_SUB)
191	{
192	CV *cv = cx->blk_sub.cv;
193	if (CvDEPTH(cv))
194	{
195	#ifdef USE_THREADS
196	XPUSHs ((SV *)CvOWNER(cv));
197	#endif
198	EXTEND (SP, 3);
199	PUSHs ((SV *)CvDEPTH(cv));
200	PUSHs ((SV *)CvPADLIST(cv));
201	PUSHs ((SV *)cv);
202
203	CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205	CvDEPTH(cv) = 0;
206	#ifdef USE_THREADS
207	CvOWNER(cv) = 0;
208	error must unlock this cv etc.. etc...
209	if you are here wondering about this error message then
210	the reason is that it will not work as advertised yet
211	#endif
212	}
213	}
214	else if (CxTYPE(cx) == CXt_FORMAT)
215	{
216	/* I never used formats, so how should I know how these are implemented? */
217	/* my bold guess is as a simple, plain sub... */
218	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219	}
220	}
221
222	if (top_si->si_type == PERLSI_MAIN)
223	break;
224
225	top_si = top_si->si_prev;
226	ccstk = top_si->si_cxstack;
227	cxix = top_si->si_cxix;
228	}
229
230	PUTBACK;
231	}
232
233	c->dowarn = PL_dowarn;
234	c->defav = GvAV (PL_defgv);
235	c->curstackinfo = PL_curstackinfo;
236	c->curstack = PL_curstack;
237	c->mainstack = PL_mainstack;
238	c->stack_sp = PL_stack_sp;
239	c->op = PL_op;
240	c->curpad = PL_curpad;
241	c->stack_base = PL_stack_base;
242	c->stack_max = PL_stack_max;
243	c->tmps_stack = PL_tmps_stack;
244	c->tmps_floor = PL_tmps_floor;
245	c->tmps_ix = PL_tmps_ix;
246	c->tmps_max = PL_tmps_max;
247	c->markstack = PL_markstack;
248	c->markstack_ptr = PL_markstack_ptr;
249	c->markstack_max = PL_markstack_max;
250	c->scopestack = PL_scopestack;
251	c->scopestack_ix = PL_scopestack_ix;
252	c->scopestack_max = PL_scopestack_max;
253	c->savestack = PL_savestack;
254	c->savestack_ix = PL_savestack_ix;
255	c->savestack_max = PL_savestack_max;
256	c->retstack = PL_retstack;
257	c->retstack_ix = PL_retstack_ix;
258	c->retstack_max = PL_retstack_max;
259	c->curcop = PL_curcop;
260	}
261
262	static void
263	LOAD(pTHX_ Coro__State c)
264	{
265	PL_dowarn = c->dowarn;
266	GvAV (PL_defgv) = c->defav;
267	PL_curstackinfo = c->curstackinfo;
268	PL_curstack = c->curstack;
269	PL_mainstack = c->mainstack;
270	PL_stack_sp = c->stack_sp;
271	PL_op = c->op;
272	PL_curpad = c->curpad;
273	PL_stack_base = c->stack_base;
274	PL_stack_max = c->stack_max;
275	PL_tmps_stack = c->tmps_stack;
276	PL_tmps_floor = c->tmps_floor;
277	PL_tmps_ix = c->tmps_ix;
278	PL_tmps_max = c->tmps_max;
279	PL_markstack = c->markstack;
280	PL_markstack_ptr = c->markstack_ptr;
281	PL_markstack_max = c->markstack_max;
282	PL_scopestack = c->scopestack;
283	PL_scopestack_ix = c->scopestack_ix;
284	PL_scopestack_max = c->scopestack_max;
285	PL_savestack = c->savestack;
286	PL_savestack_ix = c->savestack_ix;
287	PL_savestack_max = c->savestack_max;
288	PL_retstack = c->retstack;
289	PL_retstack_ix = c->retstack_ix;
290	PL_retstack_max = c->retstack_max;
291	PL_curcop = c->curcop;
292
293	{
294	dSP;
295	CV *cv;
296
297	/* now do the ugly restore mess */
298	while ((cv = (CV *)POPs))
299	{
300	AV padlist = (AV )POPs;
301
302	unuse_padlist (CvPADLIST(cv));
303	CvPADLIST(cv) = padlist;
304	CvDEPTH(cv) = (I32)POPs;
305
306	#ifdef USE_THREADS
307	CvOWNER(cv) = (struct perl_thread *)POPs;
308	error does not work either
309	#endif
310	}
311
312	PUTBACK;
313	}
314	}
315
316	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
317	STATIC void
318	S_nuke_stacks(pTHX)
319	{
320	while (PL_curstackinfo->si_next)
321	PL_curstackinfo = PL_curstackinfo->si_next;
322	while (PL_curstackinfo) {
323	PERL_SI *p = PL_curstackinfo->si_prev;
324	/* curstackinfo->si_stack got nuked by sv_free_arenas() */
325	Safefree(PL_curstackinfo->si_cxstack);
326	Safefree(PL_curstackinfo);
327	PL_curstackinfo = p;
328	}
329	Safefree(PL_tmps_stack);
330	Safefree(PL_markstack);
331	Safefree(PL_scopestack);
332	Safefree(PL_savestack);
333	Safefree(PL_retstack);
334	}
335
336	#define SUB_INIT "Coro::State::_newcoro"
337
338	MODULE = Coro::State PACKAGE = Coro::State
339
340	PROTOTYPES: ENABLE
341
342	BOOT:
343	if (!padlist_cache)
344	padlist_cache = newHV ();
345
346	Coro::State
347	_newprocess(args)
348	SV * args
349	PROTOTYPE: $
350	CODE:
351	Coro__State coro;
352
353	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
354	croak ("Coro::State::newprocess expects an arrayref");
355
356	New (0, coro, 1, struct coro);
357
358	coro->mainstack = 0; /* actual work is done inside transfer */
359	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
360
361	RETVAL = coro;
362	OUTPUT:
363	RETVAL
364
365	void
366	transfer(prev,next)
367	Coro::State_or_hashref prev
368	Coro::State_or_hashref next
369	CODE:
370
371	if (prev != next)
372	{
373	PUTBACK;
374	SAVE (aTHX_ prev);
375
376	/*
377	* this could be done in newprocess which would lead to
378	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379	* code here, but lazy allocation of stacks has also
380	* some virtues and the overhead of the if() is nil.
381	*/
382	if (next->mainstack)
383	{
384	LOAD (aTHX_ next);
385	next->mainstack = 0; /* unnecessary but much cleaner */
386	SPAGAIN;
387	}
388	else
389	{
390	/*
391	* emulate part of the perl startup here.
392	*/
393	UNOP myop;
394
395	init_stacks ();
396	PL_op = (OP *)&myop;
397	/PL_curcop = 0;/
398	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399
400	SPAGAIN;
401	Zero(&myop, 1, UNOP);
402	myop.op_next = Nullop;
403	myop.op_flags = OPf_WANT_VOID;
404
405	PUSHMARK(SP);
406	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407	PUTBACK;
408	/*
409	* the next line is slightly wrong, as PL_op->op_next
410	* is actually being executed so we skip the first op.
411	* that doesn't matter, though, since it is only
412	* pp_nextstate and we never return...
413	*/
414	PL_op = Perl_pp_entersub(aTHX);
415	SPAGAIN;
416
417	ENTER;
418	}
419	}
420
421	void
422	DESTROY(coro)
423	Coro::State coro
424	CODE:
425
426	if (coro->mainstack)
427	{
428	struct coro temp;
429
430	PUTBACK;
431	SAVE(aTHX_ (&temp));
432	LOAD(aTHX_ coro);
433
434	S_nuke_stacks ();
435	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437	LOAD((&temp));
438	SPAGAIN;
439	}
440
441	SvREFCNT_dec (coro->args);
442	Safefree (coro);
443
444