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_state(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;
}

#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)
#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)

static void
load_state(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. */
  /* OTOH, die does not have a memleak, but we do... */
  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)
          {
            /*
             * this could be done in newprocess which would lead to
             * extremely elegant and fast (just SAVE/LOAD)
             * code here, but lazy allocation of stacks has also
             * some virtues and the overhead of the if() is nil.
             */
            if (next->mainstack)
              {
                SAVE (prev);
                LOAD (next);
                /* mark this state as in-use */
                next->mainstack = 0;
                next->tmps_ix = -2;
              }
            else if (next->tmps_ix == -2)
              {
                croak ("tried to transfer to running coroutine");
              }
            else
              {
                SAVE (prev);

                /*
                 * 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;

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

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

            LOAD((&temp));
          }

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


Revision:	1.6
Committed:	Tue Jul 17 15:42:28 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.5:	+18 -11 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	root	1.6	save_state(pTHX_ Coro__State c)
190	root	1.3	{
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.6	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)
283			#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)
284
285	root	1.3	static void
286	root	1.6	load_state(pTHX_ Coro__State c)
287	root	1.3	{
288			PL_dowarn = c->dowarn;
289	root	1.2	GvAV (PL_defgv) = c->defav;
290	root	1.3	PL_curstackinfo = c->curstackinfo;
291			PL_curstack = c->curstack;
292			PL_mainstack = c->mainstack;
293			PL_stack_sp = c->stack_sp;
294			PL_op = c->op;
295			PL_curpad = c->curpad;
296			PL_stack_base = c->stack_base;
297			PL_stack_max = c->stack_max;
298			PL_tmps_stack = c->tmps_stack;
299			PL_tmps_floor = c->tmps_floor;
300			PL_tmps_ix = c->tmps_ix;
301			PL_tmps_max = c->tmps_max;
302			PL_markstack = c->markstack;
303			PL_markstack_ptr = c->markstack_ptr;
304			PL_markstack_max = c->markstack_max;
305			PL_scopestack = c->scopestack;
306			PL_scopestack_ix = c->scopestack_ix;
307			PL_scopestack_max = c->scopestack_max;
308			PL_savestack = c->savestack;
309			PL_savestack_ix = c->savestack_ix;
310			PL_savestack_max = c->savestack_max;
311			PL_retstack = c->retstack;
312			PL_retstack_ix = c->retstack_ix;
313			PL_retstack_max = c->retstack_max;
314			PL_curcop = c->curcop;
315
316			{
317			dSP;
318			CV *cv;
319
320			/* now do the ugly restore mess */
321			while ((cv = (CV *)POPs))
322			{
323			AV padlist = (AV )POPs;
324
325	root	1.4	put_padlist (cv);
326	root	1.3	CvPADLIST(cv) = padlist;
327			CvDEPTH(cv) = (I32)POPs;
328
329			#ifdef USE_THREADS
330			CvOWNER(cv) = (struct perl_thread *)POPs;
331			error does not work either
332			#endif
333			}
334
335			PUTBACK;
336			}
337			}
338	root	1.1
339			/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
340			STATIC void
341	root	1.4	destroy_stacks(pTHX)
342	root	1.1	{
343	root	1.4	/* die does this while calling POPSTACK, but I just don't see why. */
344	root	1.6	/* OTOH, die does not have a memleak, but we do... */
345	root	1.4	dounwind(-1);
346
347			/* is this ugly, I ask? */
348			while (PL_scopestack_ix)
349			LEAVE;
350
351			while (PL_curstackinfo->si_next)
352			PL_curstackinfo = PL_curstackinfo->si_next;
353
354			while (PL_curstackinfo)
355			{
356			PERL_SI *p = PL_curstackinfo->si_prev;
357
358			SvREFCNT_dec(PL_curstackinfo->si_stack);
359			Safefree(PL_curstackinfo->si_cxstack);
360			Safefree(PL_curstackinfo);
361			PL_curstackinfo = p;
362			}
363
364			if (PL_scopestack_ix != 0)
365			Perl_warner(aTHX_ WARN_INTERNAL,
366			"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367			(long)PL_scopestack_ix);
368			if (PL_savestack_ix != 0)
369			Perl_warner(aTHX_ WARN_INTERNAL,
370			"Unbalanced saves: %ld more saves than restores\n",
371			(long)PL_savestack_ix);
372			if (PL_tmps_floor != -1)
373			Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374			(long)PL_tmps_floor + 1);
375			/*
376			*/
377			Safefree(PL_tmps_stack);
378			Safefree(PL_markstack);
379			Safefree(PL_scopestack);
380			Safefree(PL_savestack);
381			Safefree(PL_retstack);
382	root	1.1	}
383
384	root	1.3	#define SUB_INIT "Coro::State::_newcoro"
385
386			MODULE = Coro::State PACKAGE = Coro::State
387	root	1.1
388			PROTOTYPES: ENABLE
389
390	root	1.3	BOOT:
391			if (!padlist_cache)
392			padlist_cache = newHV ();
393
394	root	1.1	Coro::State
395	root	1.3	_newprocess(args)
396			SV * args
397			PROTOTYPE: $
398	root	1.1	CODE:
399			Coro__State coro;
400	root	1.3
401			if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402			croak ("Coro::State::newprocess expects an arrayref");
403	root	1.1
404			New (0, coro, 1, struct coro);
405
406			coro->mainstack = 0; /* actual work is done inside transfer */
407	root	1.3	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
408	root	1.1
409			RETVAL = coro;
410			OUTPUT:
411			RETVAL
412
413			void
414			transfer(prev,next)
415	root	1.3	Coro::State_or_hashref prev
416			Coro::State_or_hashref next
417	root	1.1	CODE:
418
419	root	1.2	if (prev != next)
420	root	1.1	{
421			/*
422	root	1.3	* this could be done in newprocess which would lead to
423	root	1.6	* extremely elegant and fast (just SAVE/LOAD)
424	root	1.2	* code here, but lazy allocation of stacks has also
425			* some virtues and the overhead of the if() is nil.
426	root	1.1	*/
427	root	1.2	if (next->mainstack)
428			{
429	root	1.6	SAVE (prev);
430			LOAD (next);
431			/* mark this state as in-use */
432			next->mainstack = 0;
433			next->tmps_ix = -2;
434			}
435			else if (next->tmps_ix == -2)
436			{
437			croak ("tried to transfer to running coroutine");
438	root	1.2	}
439			else
440			{
441	root	1.6	SAVE (prev);
442
443	root	1.2	/*
444			* emulate part of the perl startup here.
445			*/
446			UNOP myop;
447
448	root	1.4	init_stacks (); /* from perl.c */
449	root	1.2	PL_op = (OP *)&myop;
450			/PL_curcop = 0;/
451	root	1.5	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
452	root	1.2
453			SPAGAIN;
454			Zero(&myop, 1, UNOP);
455			myop.op_next = Nullop;
456			myop.op_flags = OPf_WANT_VOID;
457
458	root	1.3	PUSHMARK(SP);
459			XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	root	1.2	PUTBACK;
461			/*
462			* the next line is slightly wrong, as PL_op->op_next
463	root	1.3	* is actually being executed so we skip the first op.
464			* that doesn't matter, though, since it is only
465	root	1.2	* pp_nextstate and we never return...
466			*/
467			PL_op = Perl_pp_entersub(aTHX);
468			SPAGAIN;
469	root	1.1
470	root	1.2	ENTER;
471			}
472	root	1.1	}
473
474			void
475			DESTROY(coro)
476	root	1.3	Coro::State coro
477	root	1.1	CODE:
478
479			if (coro->mainstack)
480			{
481			struct coro temp;
482
483	root	1.3	SAVE(aTHX_ (&temp));
484			LOAD(aTHX_ coro);
485	root	1.1
486	root	1.4	destroy_stacks ();
487	root	1.2	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488	root	1.1
489			LOAD((&temp));
490			}
491
492	root	1.3	SvREFCNT_dec (coro->args);
493	root	1.1	Safefree (coro);
494
495