Coro/Coro/State.xs

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

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

#define MAY_FLUSH /* increases codesize */

#define SUB_INIT "Coro::State::initialize"

#define TRANSFER_SAVE_DEFAV     0x00000001
#define TRANSFER_SAVE_DEFSV     0x00000002
#define TRANSFER_SAVE_ERRSV     0x00000004

#define TRANSFER_SAVE_ALL       -1

struct coro {
  /* optionally saved, might be zero */
  AV *defav;
  SV *defsv;
  SV *errsv;
  
  /* saved global state not related to stacks */
  U8 dowarn;

  /* the stacks and related info (callchain etc..) */
  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;

  /* data associated with this coroutine (initial args) */
  AV *args;
};

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

static AV *main_mainstack; /* used to differentiate between $main and others */

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 /* return -ENOTUNDERSTOOD */
    /* 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;
}

#ifdef MAY_FLUSH
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);
  }
}
#endif

/* the next two 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));
}

#ifdef MAY_FLUSH
STATIC void
flush_padlist_cache ()
{
  HV *hv = padlist_cache;
  padlist_cache = newHV ();

  if (hv_iterinit (hv))
    {
      HE *he;
      AV *padlist;

      while (!!(he = hv_iternext (hv)))
        {
          AV *av = (AV *)HeVAL(he);

          /* casting is fun. */
          while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
            free_padlist (padlist);
        }
    }

  SvREFCNT_dec (hv);
}
#endif

#define SB do {
#define SE } while (0)

#define LOAD(state)       SB load_state(aTHX_ state); SPAGAIN;       SE
#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE

#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE

static void
load_state(pTHX_ Coro__State c)
{
  PL_dowarn = c->dowarn;

  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;

  if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
  if (c->defsv) REPLACE_SV (DEFSV          , c->defsv);
  if (c->errsv) REPLACE_SV (ERRSV          , c->errsv);

  {
    dSP;
    CV *cv;

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

        if (padlist)
          {
            put_padlist (cv); /* mark this padlist as available */
            CvPADLIST(cv) = padlist;
#ifdef USE_THREADS
            /*CvOWNER(cv) = (struct perl_thread *)POPs;*/
#endif
          }

        ++CvDEPTH(cv);
      }

    PUTBACK;
  }
}

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

    /*
     * 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 (;;)
      {
        do
          {
            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));*/
                    /*CvOWNER(cv) = 0;*/
                    /*error must unlock this cv etc.. etc...*/
#endif
                    EXTEND (SP, CvDEPTH(cv)*2);

                    while (--CvDEPTH(cv))
                      {
                        /* this tells the restore code to increment CvDEPTH */
                        PUSHs (Nullsv);
                        PUSHs ((SV *)cv);
                      }

                    PUSHs ((SV *)CvPADLIST(cv));
                    PUSHs ((SV *)cv);

                    get_padlist (cv); /* this is a monster */
                  }
              }
            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");
              }
          }
        while (cxix >= 0);

        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->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
  c->defsv = flags & TRANSFER_SAVE_DEFSV ?       SvREFCNT_inc (DEFSV)           : 0;
  c->errsv = flags & TRANSFER_SAVE_ERRSV ?       SvREFCNT_inc (ERRSV)           : 0;

  /* I have not the slightest idea of why av_reify is necessary */
  /* but if it's missing the defav contents magically get replaced sometimes */
  if (c->defav)
    av_reify (c->defav);

  c->dowarn = PL_dowarn;

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

/*
 * destroy the stacks, the callchain etc...
 * still there is a memleak of 128 bytes...
 */
STATIC void
destroy_stacks(pTHX)
{
  /* is this ugly, I ask? */
  while (PL_scopestack_ix)
    LEAVE;

  /* sure it is, but more important: is it correct?? :/ */
  while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
    FREETMPS;

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

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

      {
        dSP;
        SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
        PUTBACK; /* possibly superfluous */
      }

      dounwind(-1);

      SvREFCNT_dec(PL_curstackinfo->si_stack);
      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);
}

STATIC void
transfer(pTHX_ struct coro *prev, struct coro *next, int flags)
{
  dSP;

  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, flags);
          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
        {
          /*
           * emulate part of the perl startup here.
           */
          UNOP myop;

          SAVE (prev, -1); /* first get rid of the old state */

          init_stacks (); /* from perl.c */
          SPAGAIN;

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

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

          PUSHMARK(SP);
          XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
          /*
           * 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...
           * ah yes, and I don't care anyways ;)
           */
          PUTBACK;
          PL_op = pp_entersub(aTHX);
          SPAGAIN;

          ENTER; /* necessary e.g. for dounwind */
        }
    }
}

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

PROTOTYPES: ENABLE

BOOT:
{       /* {} necessary for stoopid perl-5.6.x */
        HV * stash = gv_stashpvn("Coro::State", 10, TRUE);

        newCONSTSUB (stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
        newCONSTSUB (stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
        newCONSTSUB (stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));

        if (!padlist_cache)
          padlist_cache = newHV ();

        main_mainstack = PL_mainstack;
}

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, flags = TRANSFER_SAVE_ALL)
        Coro::State_or_hashref  prev
        Coro::State_or_hashref  next
        int                     flags
        PROTOTYPE: @
        CODE:

        transfer (aTHX_ prev, next, flags);

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

        if (coro->mainstack && coro->mainstack != main_mainstack)
          {
            struct coro temp;

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

            destroy_stacks ();

            LOAD((&temp)); /* this will get rid of defsv etc.. */
          }

        Safefree (coro);

        /*
         * there is one problematic case left (remember _recurse?)
         * consider the case when we
         *
         * 1. start a coroutine
         * 2. inside it descend into some xs functions
         * 3. xs function calls a callback
         * 4. callback switches to $main
         * 5. $main ends - we will end inside the xs function
         * 6. xs function returns and perl executes - what?
         *
         * to avoid this case we recurse in this function
         * and simply call my_exit(0), skipping other xs functions
         */

#if 0
void
_recurse()
        CODE:
        LEAVE;
        PL_stack_sp = PL_stack_base + ax - 1;
        PL_op = PL_op->op_next;
        CALLRUNOPS(aTHX);
        printf ("my_exit\n");
        my_exit (0);

#endif

void
flush()
        CODE:
#ifdef MAY_FLUSH
        flush_padlist_cache ();
#endif

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

# this is dirty (do you hear me?) and should be in it's own .xs

void
result(...)
        PROTOTYPE: @
        CODE:
        static SV *returnstk;
        SV *sv;
        AV *defav = GvAV (PL_defgv);
        struct coro *prev, *next;

        if (!returnstk)
          returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));

        /* set up @_ -- ugly */
        av_clear (defav);
        av_fill (defav, items - 1);
        while (items--)
          av_store (defav, items, SvREFCNT_inc (ST(items)));

        mg_get (returnstk); /* isn't documentation wrong for mg_get? */
        sv = av_pop ((AV *)SvRV (returnstk));
        prev = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 0, 0)));
        next = (struct coro *)SvIV ((SV*)SvRV (*av_fetch ((AV *)SvRV (sv), 1, 0)));
        SvREFCNT_dec (sv);
        transfer(prev, next, 0);

Revision:	1.12
Committed:	Sun Jul 22 03:24:10 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.11:	+45 -13 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.7	#if 1
6	root	1.3	# define CHK(x) (void *)0
7			#else
8			# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9			#endif
10
11	root	1.7	#define MAY_FLUSH /* increases codesize */
12
13	root	1.11	#define SUB_INIT "Coro::State::initialize"
14	root	1.8
15	root	1.12	#define TRANSFER_SAVE_DEFAV 0x00000001
16			#define TRANSFER_SAVE_DEFSV 0x00000002
17			#define TRANSFER_SAVE_ERRSV 0x00000004
18	root	1.7
19	root	1.12	#define TRANSFER_SAVE_ALL -1
20	root	1.7
21	root	1.1	struct coro {
22	root	1.7	/* optionally saved, might be zero */
23	root	1.3	AV *defav;
24	root	1.7	SV *defsv;
25			SV *errsv;
26	root	1.1
27	root	1.7	/* saved global state not related to stacks */
28			U8 dowarn;
29
30			/* the stacks and related info (callchain etc..) */
31	root	1.1	PERL_SI *curstackinfo;
32			AV *curstack;
33			AV *mainstack;
34			SV **stack_sp;
35			OP *op;
36			SV **curpad;
37			SV **stack_base;
38			SV **stack_max;
39			SV **tmps_stack;
40			I32 tmps_floor;
41			I32 tmps_ix;
42			I32 tmps_max;
43			I32 *markstack;
44			I32 *markstack_ptr;
45			I32 *markstack_max;
46			I32 *scopestack;
47			I32 scopestack_ix;
48			I32 scopestack_max;
49			ANY *savestack;
50			I32 savestack_ix;
51			I32 savestack_max;
52			OP **retstack;
53			I32 retstack_ix;
54			I32 retstack_max;
55			COP *curcop;
56
57	root	1.7	/* data associated with this coroutine (initial args) */
58	root	1.3	AV *args;
59	root	1.1	};
60
61			typedef struct coro *Coro__State;
62			typedef struct coro *Coro__State_or_hashref;
63
64	root	1.12	static AV main_mainstack; / used to differentiate between $main and others */
65
66	root	1.3	static HV *padlist_cache;
67
68			/* mostly copied from op.c:cv_clone2 */
69			STATIC AV *
70			clone_padlist (AV *protopadlist)
71			{
72			AV *av;
73			I32 ix;
74			AV protopad_name = (AV ) * av_fetch (protopadlist, 0, FALSE);
75			AV protopad = (AV ) * av_fetch (protopadlist, 1, FALSE);
76			SV **pname = AvARRAY (protopad_name);
77			SV **ppad = AvARRAY (protopad);
78			I32 fname = AvFILLp (protopad_name);
79			I32 fpad = AvFILLp (protopad);
80			AV newpadlist, newpad_name, *newpad;
81			SV **npad;
82
83			newpad_name = newAV ();
84			for (ix = fname; ix >= 0; ix--)
85			av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
86
87			newpad = newAV ();
88			av_fill (newpad, AvFILLp (protopad));
89			npad = AvARRAY (newpad);
90
91			newpadlist = newAV ();
92			AvREAL_off (newpadlist);
93			av_store (newpadlist, 0, (SV *) newpad_name);
94			av_store (newpadlist, 1, (SV *) newpad);
95
96			av = newAV (); /* will be @_ */
97			av_extend (av, 0);
98			av_store (newpad, 0, (SV *) av);
99			AvFLAGS (av) = AVf_REIFY;
100
101			for (ix = fpad; ix > 0; ix--)
102			{
103			SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;
104			if (namesv && namesv != &PL_sv_undef)
105			{
106			char name = SvPVX (namesv); / XXX */
107			if (SvFLAGS (namesv) & SVf_FAKE \|\| *name == '&')
108			{ /* lexical from outside? */
109			npad[ix] = SvREFCNT_inc (ppad[ix]);
110			}
111			else
112			{ /* our own lexical */
113			SV *sv;
114			if (*name == '&')
115			sv = SvREFCNT_inc (ppad[ix]);
116			else if (*name == '@')
117			sv = (SV *) newAV ();
118			else if (*name == '%')
119			sv = (SV *) newHV ();
120			else
121			sv = NEWSV (0, 0);
122			if (!SvPADBUSY (sv))
123			SvPADMY_on (sv);
124			npad[ix] = sv;
125			}
126			}
127			else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))
128			{
129			npad[ix] = SvREFCNT_inc (ppad[ix]);
130			}
131			else
132			{
133			SV *sv = NEWSV (0, 0);
134			SvPADTMP_on (sv);
135			npad[ix] = sv;
136			}
137			}
138
139	root	1.7	#if 0 /* return -ENOTUNDERSTOOD */
140	root	1.3	/* Now that vars are all in place, clone nested closures. */
141
142			for (ix = fpad; ix > 0; ix--) {
143			SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
144			if (namesv
145			&& namesv != &PL_sv_undef
146			&& !(SvFLAGS(namesv) & SVf_FAKE)
147			&& *SvPVX(namesv) == '&'
148			&& CvCLONE(ppad[ix]))
149			{
150			CV kid = cv_clone((CV)ppad[ix]);
151			SvREFCNT_dec(ppad[ix]);
152			CvCLONE_on(kid);
153			SvPADMY_on(kid);
154			npad[ix] = (SV*)kid;
155			}
156			}
157			#endif
158
159			return newpadlist;
160			}
161
162	root	1.7	#ifdef MAY_FLUSH
163	root	1.3	STATIC AV *
164			free_padlist (AV *padlist)
165			{
166			/* may be during global destruction */
167			if (SvREFCNT(padlist))
168			{
169			I32 i = AvFILLp(padlist);
170			while (i >= 0)
171			{
172			SV **svp = av_fetch(padlist, i--, FALSE);
173			SV sv = svp ? svp : Nullsv;
174			if (sv)
175			SvREFCNT_dec(sv);
176			}
177
178			SvREFCNT_dec((SV*)padlist);
179			}
180			}
181	root	1.7	#endif
182	root	1.3
183	root	1.7	/* the next two functions merely cache the padlists */
184	root	1.4	STATIC void
185			get_padlist (CV *cv)
186	root	1.3	{
187	root	1.4	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
188
189			if (he && AvFILLp ((AV )he) >= 0)
190			CvPADLIST (cv) = (AV )av_pop ((AV )*he);
191			else
192			CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
193			}
194
195			STATIC void
196			put_padlist (CV *cv)
197			{
198			SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);
199
200			if (SvTYPE (*he) != SVt_PVAV)
201			{
202			SvREFCNT_dec (*he);
203			he = (SV )newAV ();
204			}
205
206			av_push ((AV )he, (SV *)CvPADLIST (cv));
207	root	1.3	}
208
209	root	1.7	#ifdef MAY_FLUSH
210			STATIC void
211			flush_padlist_cache ()
212			{
213			HV *hv = padlist_cache;
214			padlist_cache = newHV ();
215
216			if (hv_iterinit (hv))
217			{
218			HE *he;
219			AV *padlist;
220
221			while (!!(he = hv_iternext (hv)))
222			{
223			AV av = (AV )HeVAL(he);
224
225			/* casting is fun. */
226			while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
227			free_padlist (padlist);
228			}
229			}
230
231			SvREFCNT_dec (hv);
232			}
233			#endif
234
235			#define SB do {
236			#define SE } while (0)
237
238			#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE
239			#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE
240
241			#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
242
243			static void
244			load_state(pTHX_ Coro__State c)
245			{
246			PL_dowarn = c->dowarn;
247
248			PL_curstackinfo = c->curstackinfo;
249			PL_curstack = c->curstack;
250			PL_mainstack = c->mainstack;
251			PL_stack_sp = c->stack_sp;
252			PL_op = c->op;
253			PL_curpad = c->curpad;
254			PL_stack_base = c->stack_base;
255			PL_stack_max = c->stack_max;
256			PL_tmps_stack = c->tmps_stack;
257			PL_tmps_floor = c->tmps_floor;
258			PL_tmps_ix = c->tmps_ix;
259			PL_tmps_max = c->tmps_max;
260			PL_markstack = c->markstack;
261			PL_markstack_ptr = c->markstack_ptr;
262			PL_markstack_max = c->markstack_max;
263			PL_scopestack = c->scopestack;
264			PL_scopestack_ix = c->scopestack_ix;
265			PL_scopestack_max = c->scopestack_max;
266			PL_savestack = c->savestack;
267			PL_savestack_ix = c->savestack_ix;
268			PL_savestack_max = c->savestack_max;
269			PL_retstack = c->retstack;
270			PL_retstack_ix = c->retstack_ix;
271			PL_retstack_max = c->retstack_max;
272			PL_curcop = c->curcop;
273
274			if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
275			if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
276			if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
277
278			{
279			dSP;
280			CV *cv;
281
282			/* now do the ugly restore mess */
283			while ((cv = (CV *)POPs))
284			{
285			AV padlist = (AV )POPs;
286
287			if (padlist)
288			{
289			put_padlist (cv); /* mark this padlist as available */
290			CvPADLIST(cv) = padlist;
291			#ifdef USE_THREADS
292			/CvOWNER(cv) = (struct perl_thread )POPs;*/
293			#endif
294			}
295
296			++CvDEPTH(cv);
297			}
298
299			PUTBACK;
300			}
301			}
302
303	root	1.3	static void
304	root	1.7	save_state(pTHX_ Coro__State c, int flags)
305	root	1.3	{
306			{
307			dSP;
308			I32 cxix = cxstack_ix;
309	root	1.11	PERL_CONTEXT *ccstk = cxstack;
310	root	1.3	PERL_SI *top_si = PL_curstackinfo;
311
312			/*
313			* the worst thing you can imagine happens first - we have to save
314			* (and reinitialize) all cv's in the whole callchain :(
315			*/
316
317			PUSHs (Nullsv);
318			/* this loop was inspired by pp_caller */
319			for (;;)
320			{
321	root	1.11	do
322	root	1.3	{
323	root	1.4	PERL_CONTEXT *cx = &ccstk[cxix--];
324	root	1.3
325			if (CxTYPE(cx) == CXt_SUB)
326			{
327			CV *cv = cx->blk_sub.cv;
328			if (CvDEPTH(cv))
329			{
330			#ifdef USE_THREADS
331	root	1.7	/XPUSHs ((SV )CvOWNER(cv));*/
332			/CvOWNER(cv) = 0;/
333			/error must unlock this cv etc.. etc.../
334	root	1.3	#endif
335	root	1.7	EXTEND (SP, CvDEPTH(cv)*2);
336
337			while (--CvDEPTH(cv))
338			{
339			/* this tells the restore code to increment CvDEPTH */
340			PUSHs (Nullsv);
341			PUSHs ((SV *)cv);
342			}
343
344	root	1.3	PUSHs ((SV *)CvPADLIST(cv));
345			PUSHs ((SV *)cv);
346
347	root	1.7	get_padlist (cv); /* this is a monster */
348	root	1.3	}
349			}
350			else if (CxTYPE(cx) == CXt_FORMAT)
351			{
352			/* I never used formats, so how should I know how these are implemented? */
353			/* my bold guess is as a simple, plain sub... */
354			croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
355			}
356			}
357	root	1.7	while (cxix >= 0);
358	root	1.3
359			if (top_si->si_type == PERLSI_MAIN)
360			break;
361
362			top_si = top_si->si_prev;
363			ccstk = top_si->si_cxstack;
364			cxix = top_si->si_cxix;
365			}
366
367			PUTBACK;
368			}
369
370	root	1.12	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
371			c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
372			c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
373	root	1.7
374	root	1.11	/* I have not the slightest idea of why av_reify is necessary */
375			/* but if it's missing the defav contents magically get replaced sometimes */
376			if (c->defav)
377			av_reify (c->defav);
378
379	root	1.3	c->dowarn = PL_dowarn;
380	root	1.7
381	root	1.3	c->curstackinfo = PL_curstackinfo;
382			c->curstack = PL_curstack;
383			c->mainstack = PL_mainstack;
384			c->stack_sp = PL_stack_sp;
385			c->op = PL_op;
386			c->curpad = PL_curpad;
387			c->stack_base = PL_stack_base;
388			c->stack_max = PL_stack_max;
389			c->tmps_stack = PL_tmps_stack;
390			c->tmps_floor = PL_tmps_floor;
391			c->tmps_ix = PL_tmps_ix;
392			c->tmps_max = PL_tmps_max;
393			c->markstack = PL_markstack;
394			c->markstack_ptr = PL_markstack_ptr;
395			c->markstack_max = PL_markstack_max;
396			c->scopestack = PL_scopestack;
397			c->scopestack_ix = PL_scopestack_ix;
398			c->scopestack_max = PL_scopestack_max;
399			c->savestack = PL_savestack;
400			c->savestack_ix = PL_savestack_ix;
401			c->savestack_max = PL_savestack_max;
402			c->retstack = PL_retstack;
403			c->retstack_ix = PL_retstack_ix;
404			c->retstack_max = PL_retstack_max;
405			c->curcop = PL_curcop;
406			}
407	root	1.1
408	root	1.7	/*
409			* destroy the stacks, the callchain etc...
410			* still there is a memleak of 128 bytes...
411			*/
412	root	1.1	STATIC void
413	root	1.4	destroy_stacks(pTHX)
414	root	1.1	{
415	root	1.4	/* is this ugly, I ask? */
416			while (PL_scopestack_ix)
417			LEAVE;
418
419	root	1.7	/* sure it is, but more important: is it correct?? :/ */
420			while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
421			FREETMPS;
422
423	root	1.4	while (PL_curstackinfo->si_next)
424			PL_curstackinfo = PL_curstackinfo->si_next;
425
426			while (PL_curstackinfo)
427			{
428			PERL_SI *p = PL_curstackinfo->si_prev;
429
430	root	1.7	{
431			dSP;
432			SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
433			PUTBACK; /* possibly superfluous */
434			}
435
436			dounwind(-1);
437
438	root	1.4	SvREFCNT_dec(PL_curstackinfo->si_stack);
439			Safefree(PL_curstackinfo->si_cxstack);
440			Safefree(PL_curstackinfo);
441			PL_curstackinfo = p;
442			}
443
444			Safefree(PL_tmps_stack);
445			Safefree(PL_markstack);
446			Safefree(PL_scopestack);
447			Safefree(PL_savestack);
448			Safefree(PL_retstack);
449	root	1.1	}
450
451	root	1.8	STATIC void
452			transfer(pTHX_ struct coro prev, struct coro next, int flags)
453			{
454			dSP;
455
456			if (prev != next)
457			{
458			/*
459			* this could be done in newprocess which would lead to
460			* extremely elegant and fast (just SAVE/LOAD)
461			* code here, but lazy allocation of stacks has also
462			* some virtues and the overhead of the if() is nil.
463			*/
464			if (next->mainstack)
465			{
466			SAVE (prev, flags);
467			LOAD (next);
468			/* mark this state as in-use */
469			next->mainstack = 0;
470			next->tmps_ix = -2;
471			}
472			else if (next->tmps_ix == -2)
473			{
474			croak ("tried to transfer to running coroutine");
475			}
476			else
477			{
478			/*
479			* emulate part of the perl startup here.
480			*/
481			UNOP myop;
482
483			SAVE (prev, -1); /* first get rid of the old state */
484
485			init_stacks (); /* from perl.c */
486			SPAGAIN;
487
488			PL_op = (OP *)&myop;
489			/PL_curcop = 0;/
490			SvREFCNT_dec (GvAV (PL_defgv));
491			GvAV (PL_defgv) = next->args;
492
493			Zero(&myop, 1, UNOP);
494			myop.op_next = Nullop;
495			myop.op_flags = OPf_WANT_VOID;
496
497			PUSHMARK(SP);
498			XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
499			/*
500			* the next line is slightly wrong, as PL_op->op_next
501			* is actually being executed so we skip the first op.
502			* that doesn't matter, though, since it is only
503			* pp_nextstate and we never return...
504			* ah yes, and I don't care anyways ;)
505			*/
506			PUTBACK;
507			PL_op = pp_entersub(aTHX);
508			SPAGAIN;
509
510			ENTER; /* necessary e.g. for dounwind */
511			}
512			}
513			}
514	root	1.3
515			MODULE = Coro::State PACKAGE = Coro::State
516	root	1.1
517			PROTOTYPES: ENABLE
518
519	root	1.3	BOOT:
520	root	1.11	{ /* {} necessary for stoopid perl-5.6.x */
521	root	1.7	HV * stash = gv_stashpvn("Coro::State", 10, TRUE);
522
523	root	1.12	newCONSTSUB (stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
524			newCONSTSUB (stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
525			newCONSTSUB (stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
526	root	1.7
527	root	1.3	if (!padlist_cache)
528			padlist_cache = newHV ();
529	root	1.12
530			main_mainstack = PL_mainstack;
531	root	1.9	}
532	root	1.3
533	root	1.1	Coro::State
534	root	1.3	_newprocess(args)
535			SV * args
536			PROTOTYPE: $
537	root	1.1	CODE:
538			Coro__State coro;
539	root	1.3
540			if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
541	root	1.7	croak ("Coro::State::_newprocess expects an arrayref");
542	root	1.1
543			New (0, coro, 1, struct coro);
544
545			coro->mainstack = 0; /* actual work is done inside transfer */
546	root	1.3	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
547	root	1.1
548			RETVAL = coro;
549			OUTPUT:
550			RETVAL
551
552			void
553	root	1.12	transfer(prev, next, flags = TRANSFER_SAVE_ALL)
554	root	1.3	Coro::State_or_hashref prev
555			Coro::State_or_hashref next
556	root	1.7	int flags
557	root	1.8	PROTOTYPE: @
558	root	1.1	CODE:
559
560	root	1.8	transfer (aTHX_ prev, next, flags);
561	root	1.1
562			void
563			DESTROY(coro)
564	root	1.3	Coro::State coro
565	root	1.1	CODE:
566
567	root	1.12	if (coro->mainstack && coro->mainstack != main_mainstack)
568	root	1.1	{
569			struct coro temp;
570
571	root	1.12	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
572	root	1.3	LOAD(aTHX_ coro);
573	root	1.1
574	root	1.4	destroy_stacks ();
575	root	1.1
576	root	1.7	LOAD((&temp)); /* this will get rid of defsv etc.. */
577	root	1.1	}
578
579			Safefree (coro);
580	root	1.12
581			/*
582			* there is one problematic case left (remember _recurse?)
583			* consider the case when we
584			*
585			* 1. start a coroutine
586			* 2. inside it descend into some xs functions
587			* 3. xs function calls a callback
588			* 4. callback switches to $main
589			* 5. $main ends - we will end inside the xs function
590			* 6. xs function returns and perl executes - what?
591			*
592			* to avoid this case we recurse in this function
593			* and simply call my_exit(0), skipping other xs functions
594			*/
595
596			#if 0
597			void
598			_recurse()
599			CODE:
600			LEAVE;
601			PL_stack_sp = PL_stack_base + ax - 1;
602			PL_op = PL_op->op_next;
603			CALLRUNOPS(aTHX);
604			printf ("my_exit\n");
605			my_exit (0);
606
607			#endif
608	root	1.7
609			void
610			flush()
611			CODE:
612			#ifdef MAY_FLUSH
613			flush_padlist_cache ();
614			#endif
615	root	1.1
616	root	1.8	MODULE = Coro::State PACKAGE = Coro::Cont
617
618	root	1.11	# this is dirty (do you hear me?) and should be in it's own .xs
619	root	1.8
620			void
621			result(...)
622			PROTOTYPE: @
623			CODE:
624			static SV *returnstk;
625			SV *sv;
626			AV *defav = GvAV (PL_defgv);
627			struct coro prev, next;
628
629			if (!returnstk)
630			returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
631
632	root	1.11	/* set up @_ -- ugly */
633	root	1.8	av_clear (defav);
634			av_fill (defav, items - 1);
635			while (items--)
636			av_store (defav, items, SvREFCNT_inc (ST(items)));
637
638			mg_get (returnstk); /* isn't documentation wrong for mg_get? */
639			sv = av_pop ((AV *)SvRV (returnstk));
640			prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
641			next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
642			SvREFCNT_dec (sv);
643			transfer(prev, next, 0);
644	root	1.1