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

  /* 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) = (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);

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

            LOAD((&temp));
            SPAGAIN;
          }

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


Revision:	1.4
Committed:	Tue Jul 17 02:21:56 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.3:	+69 -23 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	dSP;
341
342			/* die does this while calling POPSTACK, but I just don't see why. */
343			dounwind(-1);
344
345			/* is this ugly, I ask? */
346			while (PL_scopestack_ix)
347			LEAVE;
348
349			while (PL_curstackinfo->si_next)
350			PL_curstackinfo = PL_curstackinfo->si_next;
351
352			while (PL_curstackinfo)
353			{
354			PERL_SI *p = PL_curstackinfo->si_prev;
355
356			SvREFCNT_dec(PL_curstackinfo->si_stack);
357			Safefree(PL_curstackinfo->si_cxstack);
358			Safefree(PL_curstackinfo);
359			PL_curstackinfo = p;
360			}
361
362			if (PL_scopestack_ix != 0)
363			Perl_warner(aTHX_ WARN_INTERNAL,
364			"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365			(long)PL_scopestack_ix);
366			if (PL_savestack_ix != 0)
367			Perl_warner(aTHX_ WARN_INTERNAL,
368			"Unbalanced saves: %ld more saves than restores\n",
369			(long)PL_savestack_ix);
370			if (PL_tmps_floor != -1)
371			Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372			(long)PL_tmps_floor + 1);
373			/*
374			*/
375			Safefree(PL_tmps_stack);
376			Safefree(PL_markstack);
377			Safefree(PL_scopestack);
378			Safefree(PL_savestack);
379			Safefree(PL_retstack);
380	root	1.1	}
381
382	root	1.3	#define SUB_INIT "Coro::State::_newcoro"
383
384			MODULE = Coro::State PACKAGE = Coro::State
385	root	1.1
386			PROTOTYPES: ENABLE
387
388	root	1.3	BOOT:
389			if (!padlist_cache)
390			padlist_cache = newHV ();
391
392	root	1.1	Coro::State
393	root	1.3	_newprocess(args)
394			SV * args
395			PROTOTYPE: $
396	root	1.1	CODE:
397			Coro__State coro;
398	root	1.3
399			if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
400			croak ("Coro::State::newprocess expects an arrayref");
401	root	1.1
402			New (0, coro, 1, struct coro);
403
404			coro->mainstack = 0; /* actual work is done inside transfer */
405	root	1.3	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406	root	1.1
407			RETVAL = coro;
408			OUTPUT:
409			RETVAL
410
411			void
412			transfer(prev,next)
413	root	1.3	Coro::State_or_hashref prev
414			Coro::State_or_hashref next
415	root	1.1	CODE:
416
417	root	1.2	if (prev != next)
418	root	1.1	{
419	root	1.2	PUTBACK;
420	root	1.3	SAVE (aTHX_ prev);
421	root	1.1
422			/*
423	root	1.3	* this could be done in newprocess which would lead to
424	root	1.2	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425			* code here, but lazy allocation of stacks has also
426			* some virtues and the overhead of the if() is nil.
427	root	1.1	*/
428	root	1.2	if (next->mainstack)
429			{
430	root	1.3	LOAD (aTHX_ next);
431	root	1.2	next->mainstack = 0; /* unnecessary but much cleaner */
432			SPAGAIN;
433			}
434			else
435			{
436			/*
437			* emulate part of the perl startup here.
438			*/
439			UNOP myop;
440
441	root	1.4	init_stacks (); /* from perl.c */
442	root	1.2	PL_op = (OP *)&myop;
443			/PL_curcop = 0;/
444	root	1.3	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445	root	1.2
446			SPAGAIN;
447			Zero(&myop, 1, UNOP);
448			myop.op_next = Nullop;
449			myop.op_flags = OPf_WANT_VOID;
450
451	root	1.3	PUSHMARK(SP);
452			XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	root	1.2	PUTBACK;
454			/*
455			* the next line is slightly wrong, as PL_op->op_next
456	root	1.3	* is actually being executed so we skip the first op.
457			* that doesn't matter, though, since it is only
458	root	1.2	* pp_nextstate and we never return...
459			*/
460			PL_op = Perl_pp_entersub(aTHX);
461			SPAGAIN;
462	root	1.1
463	root	1.2	ENTER;
464			}
465	root	1.1	}
466
467			void
468			DESTROY(coro)
469	root	1.3	Coro::State coro
470	root	1.1	CODE:
471
472			if (coro->mainstack)
473			{
474			struct coro temp;
475
476			PUTBACK;
477	root	1.3	SAVE(aTHX_ (&temp));
478			LOAD(aTHX_ coro);
479	root	1.1
480	root	1.4	destroy_stacks ();
481	root	1.2	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482	root	1.1
483			LOAD((&temp));
484			SPAGAIN;
485			}
486
487	root	1.3	SvREFCNT_dec (coro->args);
488	root	1.1	Safefree (coro);
489
490