Coro/Coro/State.xs

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

#include "libcoro/coro.c"

#ifdef HAVE_MMAP
# include <unistd.h>
# include <sys/mman.h>
#endif

#define MAY_FLUSH /* increases codesize */

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

#define TRANSFER_SAVE_ALL       -1

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

struct coro {
  /* the optional C context */
  coro_context cctx;
  void *sptr;
  long ssize;

  /* 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;
  JMPENV start_env;
  JMPENV *top_env;

  /* 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 *coro_state_stash;
static SV *ucoro_state_sv;
static U32 ucoro_state_hash;
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;
  PL_start_env = c->start_env;
  PL_top_env = c->top_env;

  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;
  c->start_env = PL_start_env;
  c->top_env = PL_top_env;
}

/*
 * allocate various perl stacks. This is an exact copy
 * of perl.c:init_stacks, except that it uses less memory
 * on the assumption that coroutines do not usually need
 * a lot of stackspace.
 */
STATIC void
coro_init_stacks (pTHX)
{
    PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
    PL_curstackinfo->si_type = PERLSI_MAIN;
    PL_curstack = PL_curstackinfo->si_stack;
    PL_mainstack = PL_curstack;         /* remember in case we switch stacks */

    PL_stack_base = AvARRAY(PL_curstack);
    PL_stack_sp = PL_stack_base;
    PL_stack_max = PL_stack_base + AvMAX(PL_curstack);

    New(50,PL_tmps_stack,64,SV*);
    PL_tmps_floor = -1;
    PL_tmps_ix = -1;
    PL_tmps_max = 64;

    New(54,PL_markstack,12,I32);
    PL_markstack_ptr = PL_markstack;
    PL_markstack_max = PL_markstack + 12;

    SET_MARK_OFFSET;

    New(54,PL_scopestack,12,I32);
    PL_scopestack_ix = 0;
    PL_scopestack_max = 12;

    New(54,PL_savestack,64,ANY);
    PL_savestack_ix = 0;
    PL_savestack_max = 64;

    New(54,PL_retstack,8,OP*);
    PL_retstack_ix = 0;
    PL_retstack_max = 8;
}

/*
 * 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
allocate_stack (Coro__State ctx)
{
#ifdef HAVE_MMAP 
  ctx->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
  ctx->sptr = mmap (0, ctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
  if (ctx->sptr == (void *)-1)
#endif
    {
      /*FIXME*//*D*//* reasonable stack size! */
      ctx->ssize = 4096 * sizeof (long);
      New (0, ctx->sptr, 4096, long);
    }
}

static void
deallocate_stack (Coro__State ctx)
{
#ifdef HAVE_MMAP
  munmap (ctx->sptr, ctx->ssize);
#else
  Safefree (ctx->sptr);
#endif
}

/* might go away together with optional SAVE_CCTXT */
static void
setup_coro (void *arg)
{
  /*
   * emulate part of the perl startup here.
   */
  dSP;
  Coro__State ctx = (Coro__State)arg;
  SV *sub_init = (SV*)get_cv(SUB_INIT, FALSE);

  coro_init_stacks (aTHX);
  JMPENV_BOOTSTRAP;
  SPAGAIN;

  /*PL_curcop = 0;*/
  SvREFCNT_dec (GvAV (PL_defgv));
  GvAV (PL_defgv) = ctx->args;

  if (ctx->sptr)
    {
      PUSHMARK(SP);
      PUTBACK;
      (void) call_sv (sub_init, G_VOID|G_NOARGS);
      croak ("FATAL: CCTXT coroutine returned!");
    }
  else
    {
      UNOP myop;

      PL_op = (OP *)&myop;

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

      PUSHMARK(SP);
      XPUSHs (sub_init);
      /*
       * 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();
      SPAGAIN;

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

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

          if (flags & TRANSFER_SAVE_CCTXT)
            {
              if (!next->ssize)
                croak ("destination coroutine has no CCTXT (%p, %d)", next->sptr, next->ssize);

              if (!prev->ssize)
                prev->ssize = 1; /* mark cctx as valid ;) */

              coro_transfer (&(prev->cctx), &(next->cctx));
            }

        }
      else if (next->tmps_ix == -2)
        croak ("tried to transfer to running coroutine");
      else
        {
          SAVE (prev, -1); /* first get rid of the old state */

          if (flags & TRANSFER_SAVE_CCTXT)
            {
              if (!next->ssize)
                {
                  allocate_stack (next);
                  coro_create (&(next->cctx),
                               setup_coro, (void *)next,
                               next->sptr, next->ssize);
                }

              if (!prev->ssize)
                prev->ssize = 1; /* mark cctx as valid ;) */

              coro_transfer (&(prev->cctx), &(next->cctx));
            }
          else
            setup_coro (next);
        }
    }
}

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

PROTOTYPES: ENABLE

BOOT:
{       /* {} necessary for stoopid perl-5.6.x */
        ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
        PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
        coro_state_stash = gv_stashpv ("Coro::State", TRUE);

        newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
        newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
        newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
        newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));

        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->args = (AV *)SvREFCNT_inc (SvRV (args));
        coro->mainstack = 0; /* actual work is done inside transfer */
        coro->sptr = 0;
        coro->ssize = 0;

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

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

            coro->mainstack = 0;
          }

        if (coro->sptr)
          {
            deallocate_stack (coro);
            coro->sptr = 0;
          }

        Safefree (coro);

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

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

# this is slightly dirty

void
yield(...)
        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(aTHX_ prev, next, 0);

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