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

/* perl-related */
#define TRANSFER_SAVE_DEFAV     0x00000001
#define TRANSFER_SAVE_DEFSV     0x00000002
#define TRANSFER_SAVE_ERRSV     0x00000004
/* c-related */
#define TRANSFER_SAVE_CCTXT     0x00000008
#ifdef CORO_LAZY_STACK
# define TRANSFER_LAZY_STACK    0x00000010
#else
# define TRANSFER_LAZY_STACK    0x00000000
#endif

#define TRANSFER_SAVE_ALL       (TRANSFER_SAVE_DEFAV|TRANSFER_SAVE_DEFSV \
                                |TRANSFER_SAVE_ERRSV|TRANSFER_SAVE_CCTXT)

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

/* The next macro should delcare a variable stacklevel that contains and approximation
 * to the current C stack pointer. It's property is that it changes with each call
 * and should be unique. */
#define dSTACKLEVEL void *stacklevel = &stacklevel

#define labs(l) ((l) >= 0 ? (l) : -(l))

/* this is actually not only the c stack but also c registers etc... */
typedef struct {
  int refcnt; /* pointer reference counter */
  int usecnt; /* shared by how many coroutines */
  int gencnt; /* generation counter */

  coro_context cctx;

  void *sptr;
  long ssize; /* positive == mmap, otherwise malloc */
} coro_stack;

static coro_stack main_stack = { 1, 0, 0 };

struct coro {
  /* the optional C context */
  coro_stack *stack;
  void *cursp;
  int gencnt;

  /* 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,96,SV*);
    PL_tmps_floor = -1;
    PL_tmps_ix = -1;
    PL_tmps_max = 96;

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

    SET_MARK_OFFSET;

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

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

    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, int alloc)
{
  coro_stack *stack;

  New (0, stack, 1, coro_stack);

  stack->refcnt = 1;
  stack->usecnt = 1;
  stack->gencnt = ctx->gencnt = 0;
  if (alloc)
    {
#ifdef HAVE_MMAP 
      stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
      stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, 0, 0);
      if (stack->sptr == (void *)-1)
#endif
        {
          /*FIXME*//*D*//* reasonable stack size! */
          stack->ssize = -4096 * sizeof (long);
          New (0, stack->sptr, 4096, long);
        }
    }
  else
    stack->sptr = 0;

  ctx->stack = stack;
}

static void
deallocate_stack (Coro__State ctx)
{
  coro_stack *stack = ctx->stack;

  ctx->stack = 0;

  if (stack)
    {
      if (!--stack->refcnt)
        {
#ifdef HAVE_MMAP
          if (stack->ssize > 0 && stack->sptr)
            munmap (stack->sptr, stack->ssize);
          else
#else
            Safefree (stack->sptr);
#endif
          Safefree (stack);
        }
      else if (ctx->gencnt == stack->gencnt)
        --stack->usecnt;
    }
}

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->stack)
    {
      ctx->cursp = 0;

      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
continue_coro (void *arg)
{
  /*
   * this is a _very_ stripped down perl interpreter ;)
   */
  Coro__State ctx = (Coro__State)arg;

  ctx->cursp = 0;
  PL_op = PL_op->op_next;
  CALLRUNOPS(aTHX);
  /*NORETURN*/
  abort ();
}

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

  if (prev != next)
    {
      if (next->mainstack)
        {
          SAVE (prev, flags);
          LOAD (next);

          /* mark this state as in-use */
          next->mainstack = 0;
          next->tmps_ix = -2;

          /* stacklevel changed? if yes, grab the stack for us! */
          if (flags & TRANSFER_SAVE_CCTXT)
            {
              if (!prev->stack)
                allocate_stack (prev, 0);
              else if (prev->cursp != stacklevel
                       && prev->stack->usecnt > 1)
                {
                  prev->gencnt = ++prev->stack->gencnt;
                  prev->stack->usecnt = 1;
                }

              /* has our stack been invalidated? */
              if (next->stack && next->stack->gencnt != next->gencnt)
                {
                  deallocate_stack (next);
                  allocate_stack (next, 1);
                  coro_create (&(next->stack->cctx),
                               continue_coro, (void *)next,
                               next->stack->sptr, labs (next->stack->ssize));
                }

              coro_transfer (&(prev->stack->cctx), &(next->stack->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 (!prev->stack)
                allocate_stack (prev, 0);

              if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
                {
                  setup_coro (next);

                  prev->stack->refcnt++;
                  prev->stack->usecnt++;
                  next->stack = prev->stack;
                  next->gencnt = prev->gencnt;
                }
              else
                {
                  allocate_stack (next, 1);
                  coro_create (&(next->stack->cctx),
                               setup_coro, (void *)next,
                               next->stack->sptr, labs (next->stack->ssize));
                  coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
                }
            }
          else
            setup_coro (next);
        }
    }

  next->cursp = stacklevel;
}

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->stack = 0;

        RETVAL = coro;
        OUTPUT:
        RETVAL

void
transfer(prev, next, flags = TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK)
        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;
          }

        deallocate_stack (coro);

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