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);
  }
}

/* the next tow functions merely cache the padlists */
STATIC void
get_padlist (CV *cv)
{
  SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);

  if (he && AvFILLp ((AV *)*he) >= 0)
    CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
  else
    CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
}

STATIC void
put_padlist (CV *cv)
{
  SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);

  if (SvTYPE (*he) != SVt_PVAV)
    {
      SvREFCNT_dec (*he);
      *he = (SV *)newAV ();
    }

  av_push ((AV *)*he, (SV *)CvPADLIST (cv));
}

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);

                    get_padlist (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;

        put_padlist (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
destroy_stacks(pTHX)
{
  /* die does this while calling POPSTACK, but I just don't see why. */
  dounwind(-1);

  /* is this ugly, I ask? */
  while (PL_scopestack_ix)
    LEAVE;

  while (PL_curstackinfo->si_next)
    PL_curstackinfo = PL_curstackinfo->si_next;

  while (PL_curstackinfo)
    {
      PERL_SI *p = PL_curstackinfo->si_prev;

      SvREFCNT_dec(PL_curstackinfo->si_stack);
      Safefree(PL_curstackinfo->si_cxstack);
      Safefree(PL_curstackinfo);
      PL_curstackinfo = p;
  }

        if (PL_scopestack_ix != 0)
            Perl_warner(aTHX_ WARN_INTERNAL,
                 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
                 (long)PL_scopestack_ix);
        if (PL_savestack_ix != 0)
            Perl_warner(aTHX_ WARN_INTERNAL,
                 "Unbalanced saves: %ld more saves than restores\n",
                 (long)PL_savestack_ix);
        if (PL_tmps_floor != -1)
            Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
                 (long)PL_tmps_floor + 1);
  /*
                 */
  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 (); /* from perl.c */
                PL_op = (OP *)&myop;
                /*PL_curcop = 0;*/
                GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)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);

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

            LOAD((&temp));
            SPAGAIN;
          }

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


Revision:	1.5
Committed:	Tue Jul 17 02:55:29 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.4:	+1 -3 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	root	1.4	/* the next tow functions merely cache the padlists */
163			STATIC void
164			get_padlist (CV *cv)
165	root	1.3	{
166	root	1.4	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
167
168			if (he && AvFILLp ((AV )he) >= 0)
169			CvPADLIST (cv) = (AV )av_pop ((AV )*he);
170			else
171			CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172			}
173
174			STATIC void
175			put_padlist (CV *cv)
176			{
177			SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);
178
179			if (SvTYPE (*he) != SVt_PVAV)
180			{
181			SvREFCNT_dec (*he);
182			he = (SV )newAV ();
183			}
184
185			av_push ((AV )he, (SV *)CvPADLIST (cv));
186	root	1.3	}
187
188			static void
189			SAVE(pTHX_ Coro__State c)
190			{
191			{
192			dSP;
193			I32 cxix = cxstack_ix;
194			PERL_SI *top_si = PL_curstackinfo;
195			PERL_CONTEXT *ccstk = cxstack;
196
197			/*
198			* the worst thing you can imagine happens first - we have to save
199			* (and reinitialize) all cv's in the whole callchain :(
200			*/
201
202			PUSHs (Nullsv);
203			/* this loop was inspired by pp_caller */
204			for (;;)
205			{
206			while (cxix >= 0)
207			{
208	root	1.4	PERL_CONTEXT *cx = &ccstk[cxix--];
209	root	1.3
210			if (CxTYPE(cx) == CXt_SUB)
211			{
212			CV *cv = cx->blk_sub.cv;
213			if (CvDEPTH(cv))
214			{
215			#ifdef USE_THREADS
216			XPUSHs ((SV *)CvOWNER(cv));
217			#endif
218			EXTEND (SP, 3);
219			PUSHs ((SV *)CvDEPTH(cv));
220			PUSHs ((SV *)CvPADLIST(cv));
221			PUSHs ((SV *)cv);
222
223	root	1.4	get_padlist (cv);
224	root	1.3
225			CvDEPTH(cv) = 0;
226			#ifdef USE_THREADS
227			CvOWNER(cv) = 0;
228			error must unlock this cv etc.. etc...
229			if you are here wondering about this error message then
230			the reason is that it will not work as advertised yet
231			#endif
232			}
233			}
234			else if (CxTYPE(cx) == CXt_FORMAT)
235			{
236			/* I never used formats, so how should I know how these are implemented? */
237			/* my bold guess is as a simple, plain sub... */
238			croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239			}
240			}
241
242			if (top_si->si_type == PERLSI_MAIN)
243			break;
244
245			top_si = top_si->si_prev;
246			ccstk = top_si->si_cxstack;
247			cxix = top_si->si_cxix;
248			}
249
250			PUTBACK;
251			}
252
253			c->dowarn = PL_dowarn;
254	root	1.2	c->defav = GvAV (PL_defgv);
255	root	1.3	c->curstackinfo = PL_curstackinfo;
256			c->curstack = PL_curstack;
257			c->mainstack = PL_mainstack;
258			c->stack_sp = PL_stack_sp;
259			c->op = PL_op;
260			c->curpad = PL_curpad;
261			c->stack_base = PL_stack_base;
262			c->stack_max = PL_stack_max;
263			c->tmps_stack = PL_tmps_stack;
264			c->tmps_floor = PL_tmps_floor;
265			c->tmps_ix = PL_tmps_ix;
266			c->tmps_max = PL_tmps_max;
267			c->markstack = PL_markstack;
268			c->markstack_ptr = PL_markstack_ptr;
269			c->markstack_max = PL_markstack_max;
270			c->scopestack = PL_scopestack;
271			c->scopestack_ix = PL_scopestack_ix;
272			c->scopestack_max = PL_scopestack_max;
273			c->savestack = PL_savestack;
274			c->savestack_ix = PL_savestack_ix;
275			c->savestack_max = PL_savestack_max;
276			c->retstack = PL_retstack;
277			c->retstack_ix = PL_retstack_ix;
278			c->retstack_max = PL_retstack_max;
279			c->curcop = PL_curcop;
280			}
281	root	1.1
282	root	1.3	static void
283			LOAD(pTHX_ Coro__State c)
284			{
285			PL_dowarn = c->dowarn;
286	root	1.2	GvAV (PL_defgv) = c->defav;
287	root	1.3	PL_curstackinfo = c->curstackinfo;
288			PL_curstack = c->curstack;
289			PL_mainstack = c->mainstack;
290			PL_stack_sp = c->stack_sp;
291			PL_op = c->op;
292			PL_curpad = c->curpad;
293			PL_stack_base = c->stack_base;
294			PL_stack_max = c->stack_max;
295			PL_tmps_stack = c->tmps_stack;
296			PL_tmps_floor = c->tmps_floor;
297			PL_tmps_ix = c->tmps_ix;
298			PL_tmps_max = c->tmps_max;
299			PL_markstack = c->markstack;
300			PL_markstack_ptr = c->markstack_ptr;
301			PL_markstack_max = c->markstack_max;
302			PL_scopestack = c->scopestack;
303			PL_scopestack_ix = c->scopestack_ix;
304			PL_scopestack_max = c->scopestack_max;
305			PL_savestack = c->savestack;
306			PL_savestack_ix = c->savestack_ix;
307			PL_savestack_max = c->savestack_max;
308			PL_retstack = c->retstack;
309			PL_retstack_ix = c->retstack_ix;
310			PL_retstack_max = c->retstack_max;
311			PL_curcop = c->curcop;
312
313			{
314			dSP;
315			CV *cv;
316
317			/* now do the ugly restore mess */
318			while ((cv = (CV *)POPs))
319			{
320			AV padlist = (AV )POPs;
321
322	root	1.4	put_padlist (cv);
323	root	1.3	CvPADLIST(cv) = padlist;
324			CvDEPTH(cv) = (I32)POPs;
325
326			#ifdef USE_THREADS
327			CvOWNER(cv) = (struct perl_thread *)POPs;
328			error does not work either
329			#endif
330			}
331
332			PUTBACK;
333			}
334			}
335	root	1.1
336			/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
337			STATIC void
338	root	1.4	destroy_stacks(pTHX)
339	root	1.1	{
340	root	1.4	/* die does this while calling POPSTACK, but I just don't see why. */
341			dounwind(-1);
342
343			/* is this ugly, I ask? */
344			while (PL_scopestack_ix)
345			LEAVE;
346
347			while (PL_curstackinfo->si_next)
348			PL_curstackinfo = PL_curstackinfo->si_next;
349
350			while (PL_curstackinfo)
351			{
352			PERL_SI *p = PL_curstackinfo->si_prev;
353
354			SvREFCNT_dec(PL_curstackinfo->si_stack);
355			Safefree(PL_curstackinfo->si_cxstack);
356			Safefree(PL_curstackinfo);
357			PL_curstackinfo = p;
358			}
359
360			if (PL_scopestack_ix != 0)
361			Perl_warner(aTHX_ WARN_INTERNAL,
362			"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363			(long)PL_scopestack_ix);
364			if (PL_savestack_ix != 0)
365			Perl_warner(aTHX_ WARN_INTERNAL,
366			"Unbalanced saves: %ld more saves than restores\n",
367			(long)PL_savestack_ix);
368			if (PL_tmps_floor != -1)
369			Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370			(long)PL_tmps_floor + 1);
371			/*
372			*/
373			Safefree(PL_tmps_stack);
374			Safefree(PL_markstack);
375			Safefree(PL_scopestack);
376			Safefree(PL_savestack);
377			Safefree(PL_retstack);
378	root	1.1	}
379
380	root	1.3	#define SUB_INIT "Coro::State::_newcoro"
381
382			MODULE = Coro::State PACKAGE = Coro::State
383	root	1.1
384			PROTOTYPES: ENABLE
385
386	root	1.3	BOOT:
387			if (!padlist_cache)
388			padlist_cache = newHV ();
389
390	root	1.1	Coro::State
391	root	1.3	_newprocess(args)
392			SV * args
393			PROTOTYPE: $
394	root	1.1	CODE:
395			Coro__State coro;
396	root	1.3
397			if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398			croak ("Coro::State::newprocess expects an arrayref");
399	root	1.1
400			New (0, coro, 1, struct coro);
401
402			coro->mainstack = 0; /* actual work is done inside transfer */
403	root	1.3	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404	root	1.1
405			RETVAL = coro;
406			OUTPUT:
407			RETVAL
408
409			void
410			transfer(prev,next)
411	root	1.3	Coro::State_or_hashref prev
412			Coro::State_or_hashref next
413	root	1.1	CODE:
414
415	root	1.2	if (prev != next)
416	root	1.1	{
417	root	1.2	PUTBACK;
418	root	1.3	SAVE (aTHX_ prev);
419	root	1.1
420			/*
421	root	1.3	* this could be done in newprocess which would lead to
422	root	1.2	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423			* code here, but lazy allocation of stacks has also
424			* some virtues and the overhead of the if() is nil.
425	root	1.1	*/
426	root	1.2	if (next->mainstack)
427			{
428	root	1.3	LOAD (aTHX_ next);
429	root	1.2	next->mainstack = 0; /* unnecessary but much cleaner */
430			SPAGAIN;
431			}
432			else
433			{
434			/*
435			* emulate part of the perl startup here.
436			*/
437			UNOP myop;
438
439	root	1.4	init_stacks (); /* from perl.c */
440	root	1.2	PL_op = (OP *)&myop;
441			/PL_curcop = 0;/
442	root	1.5	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
443	root	1.2
444			SPAGAIN;
445			Zero(&myop, 1, UNOP);
446			myop.op_next = Nullop;
447			myop.op_flags = OPf_WANT_VOID;
448
449	root	1.3	PUSHMARK(SP);
450			XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	root	1.2	PUTBACK;
452			/*
453			* the next line is slightly wrong, as PL_op->op_next
454	root	1.3	* is actually being executed so we skip the first op.
455			* that doesn't matter, though, since it is only
456	root	1.2	* pp_nextstate and we never return...
457			*/
458			PL_op = Perl_pp_entersub(aTHX);
459			SPAGAIN;
460	root	1.1
461	root	1.2	ENTER;
462			}
463	root	1.1	}
464
465			void
466			DESTROY(coro)
467	root	1.3	Coro::State coro
468	root	1.1	CODE:
469
470			if (coro->mainstack)
471			{
472			struct coro temp;
473
474			PUTBACK;
475	root	1.3	SAVE(aTHX_ (&temp));
476			LOAD(aTHX_ coro);
477	root	1.1
478	root	1.4	destroy_stacks ();
479	root	1.2	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480	root	1.1
481			LOAD((&temp));
482			SPAGAIN;
483			}
484
485	root	1.3	SvREFCNT_dec (coro->args);
486	root	1.1	Safefree (coro);
487
488