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>
# ifndef MAP_ANON
#  ifdef MAP_ANONYMOUS
#   define MAP_ANON MAP_ANONYMOUS
#  else
#   undef HAVE_MMAP
#  endif
# endif
#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;

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