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 *
#	User	Rev	Content
1	root	1.1	#include "EXTERN.h"
2			#include "perl.h"
3			#include "XSUB.h"
4
5	root	1.3	#if 0
6			# define CHK(x) (void *)0
7			#else
8			# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9			#endif
10
11	root	1.1	struct coro {
12			U8 dowarn;
13	root	1.3	AV *defav;
14	root	1.1
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	root	1.3	AV *args;
42	root	1.1	};
43
44			typedef struct coro *Coro__State;
45			typedef struct coro *Coro__State_or_hashref;
46
47	root	1.3	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	root	1.2	c->defav = GvAV (PL_defgv);
235	root	1.3	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	root	1.1
262	root	1.3	static void
263			LOAD(pTHX_ Coro__State c)
264			{
265			PL_dowarn = c->dowarn;
266	root	1.2	GvAV (PL_defgv) = c->defav;
267	root	1.3	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	root	1.1
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	root	1.3	PL_curstackinfo = PL_curstackinfo->si_next;
322	root	1.1	while (PL_curstackinfo) {
323	root	1.3	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	root	1.1	}
329			Safefree(PL_tmps_stack);
330			Safefree(PL_markstack);
331			Safefree(PL_scopestack);
332			Safefree(PL_savestack);
333			Safefree(PL_retstack);
334			}
335
336	root	1.3	#define SUB_INIT "Coro::State::_newcoro"
337
338			MODULE = Coro::State PACKAGE = Coro::State
339	root	1.1
340			PROTOTYPES: ENABLE
341
342	root	1.3	BOOT:
343			if (!padlist_cache)
344			padlist_cache = newHV ();
345
346	root	1.1	Coro::State
347	root	1.3	_newprocess(args)
348			SV * args
349			PROTOTYPE: $
350	root	1.1	CODE:
351			Coro__State coro;
352	root	1.3
353			if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
354			croak ("Coro::State::newprocess expects an arrayref");
355	root	1.1
356			New (0, coro, 1, struct coro);
357
358			coro->mainstack = 0; /* actual work is done inside transfer */
359	root	1.3	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
360	root	1.1
361			RETVAL = coro;
362			OUTPUT:
363			RETVAL
364
365			void
366			transfer(prev,next)
367	root	1.3	Coro::State_or_hashref prev
368			Coro::State_or_hashref next
369	root	1.1	CODE:
370
371	root	1.2	if (prev != next)
372	root	1.1	{
373	root	1.2	PUTBACK;
374	root	1.3	SAVE (aTHX_ prev);
375	root	1.1
376			/*
377	root	1.3	* this could be done in newprocess which would lead to
378	root	1.2	* 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	root	1.1	*/
382	root	1.2	if (next->mainstack)
383			{
384	root	1.3	LOAD (aTHX_ next);
385	root	1.2	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	root	1.3	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399	root	1.2
400			SPAGAIN;
401			Zero(&myop, 1, UNOP);
402			myop.op_next = Nullop;
403			myop.op_flags = OPf_WANT_VOID;
404
405	root	1.3	PUSHMARK(SP);
406			XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407	root	1.2	PUTBACK;
408			/*
409			* the next line is slightly wrong, as PL_op->op_next
410	root	1.3	* is actually being executed so we skip the first op.
411			* that doesn't matter, though, since it is only
412	root	1.2	* pp_nextstate and we never return...
413			*/
414			PL_op = Perl_pp_entersub(aTHX);
415			SPAGAIN;
416	root	1.1
417	root	1.2	ENTER;
418			}
419	root	1.1	}
420
421			void
422			DESTROY(coro)
423	root	1.3	Coro::State coro
424	root	1.1	CODE:
425
426			if (coro->mainstack)
427			{
428			struct coro temp;
429
430			PUTBACK;
431	root	1.3	SAVE(aTHX_ (&temp));
432			LOAD(aTHX_ coro);
433	root	1.1
434			S_nuke_stacks ();
435	root	1.2	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436	root	1.1
437			LOAD((&temp));
438			SPAGAIN;
439			}
440
441	root	1.3	SvREFCNT_dec (coro->args);
442	root	1.1	Safefree (coro);
443
444