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;

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