view release on metacpan or  search on metacpan

Coro/clone.c  view on Meta::CPAN

/* clone implementation, big, slow, useless, but not pointless */

static AV *
clone_av (pTHX_ AV *av)
{
  int i;
  AV *nav = newAV ();

  av_fill (nav, AvFILLp (av));

  for (i = 0; i <= AvFILLp (av); ++i)
    AvARRAY (nav)[i] = SvREFCNT_inc (AvARRAY (av)[i]);

  return nav;
}

static struct coro *
coro_clone (pTHX_ struct coro *coro)
{
  perl_slots *slot, *nslot;
  struct coro *ncoro;

  if (coro->flags & (CF_RUNNING | CF_NEW))
    croak ("Coro::State::clone cannot clone new or running states, caught");

  if (coro->cctx)
    croak ("Coro::State::clone cannot clone a state running on a custom C context, caught");

  /* TODO: maybe check slf_frame for prpeare_rransfer/check_nop? */

  slot = coro->slot;

  if (slot->curstackinfo->si_type != PERLSI_MAIN)
    croak ("Coro::State::clone cannot clone a state running on a non-main stack, caught");

  Newz (0, ncoro, 1, struct coro);
  Newz (0, nslot, 1, perl_slots);

  /* copy first, then fixup */
  *ncoro = *coro;
  *nslot = *slot;
  ncoro->slot = nslot;

  nslot->curstackinfo = new_stackinfo (slot->stack_max - slot->stack_sp + 1, slot->curstackinfo->si_cxmax);
  nslot->curstackinfo->si_type = PERLSI_MAIN;
  nslot->curstackinfo->si_cxix = slot->curstackinfo->si_cxix;
  nslot->curstack = nslot->curstackinfo->si_stack;
  ncoro->mainstack = nslot->curstack;

  nslot->stack_base = AvARRAY (nslot->curstack);
  nslot->stack_sp   = nslot->stack_base + (slot->stack_sp - slot->stack_base);
  nslot->stack_max  = nslot->stack_base + AvMAX (nslot->curstack);

  Copy (slot->stack_base, nslot->stack_base, slot->stack_sp - slot->stack_base + 1, SV *);
  Copy (slot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxstack, nslot->curstackinfo->si_cxix + 1, PERL_CONTEXT);

  New (50, nslot->tmps_stack, nslot->tmps_max, SV *);
  Copy (slot->tmps_stack, nslot->tmps_stack, slot->tmps_ix + 1, SV *);

  New (54, nslot->markstack, slot->markstack_max - slot->markstack + 1, I32);
  nslot->markstack_ptr = nslot->markstack + (slot->markstack_ptr - slot->markstack);
  nslot->markstack_max = nslot->markstack + (slot->markstack_max - slot->markstack);
  Copy (slot->markstack, nslot->markstack, slot->markstack_ptr - slot->markstack + 1, I32);

#ifdef SET_MARK_OFFSET
    //SET_MARK_OFFSET; /*TODO*/
#endif

  New (54, nslot->scopestack, slot->scopestack_max, I32);
  Copy (slot->scopestack, nslot->scopestack, slot->scopestack_ix + 1, I32);

  New (54, nslot->savestack, nslot->savestack_max, ANY);
  Copy (slot->savestack, nslot->savestack, slot->savestack_ix + 1, ANY);

#if !PERL_VERSION_ATLEAST (5,10,0)
  New (54, nslot->retstack, nslot->retstack_max, OP *);
  Copy (slot->retstack, nslot->retstack, slot->retstack_max, OP *);
#endif

  /* first fix up the padlists, by walking up our own saved state */
  {
    SV **sp = nslot->stack_sp;
    AV *av;
    CV *cv;
    int i;

    /* now do the ugly restore mess */
    while (expect_true (cv = (CV *)POPs))
      {
        /* cv will be refcnt_inc'ed twice by the following two loops */
        POPs;

        /* need to clone the padlist */
        /* this simplistic hack is most likely wrong */
        av = clone_av (aTHX_ (AV *)TOPs);
        AvREAL_off (av);

        for (i = 1; i <= AvFILLp (av); ++i)
          {
            SvREFCNT_dec (AvARRAY (av)[i]);
            AvARRAY (av)[i] = (SV *)clone_av (aTHX_ (AV *)AvARRAY (av)[i]);
            AvREIFY_only (AvARRAY (av)[i]);
          }

        TOPs = (SV *)av;

        POPs;
      }

Coro/clone.c  view on Meta::CPAN

                new_state->re_state_regeol = pv_dup (old_state->re_state_regeol);
                new_state->re_state_regoffs = (regexp_paren_pair *) any_dup (old_state->re_state_regoffs, proto_perl);
                new_state->re_state_reglastparen = (U32 *) any_dup (old_state->re_state_reglastparen, proto_perl);
                new_state->re_state_reglastcloseparen = (U32 *) any_dup (old_state->re_state_reglastcloseparen, proto_perl);
                /* XXX This just has to be broken. The old save_re_context
                   code did SAVEGENERICPV(PL_reg_start_tmp);
                   PL_reg_start_tmp is char **.
                   Look above to what the dup code does for
                   SAVEt_GENERIC_PVREF
                   It can never have worked.
                   So this is merely a faithful copy of the exiting bug:  */
                new_state->re_state_reg_start_tmp = (char **) pv_dup ((char *) old_state->re_state_reg_start_tmp);
                /* I assume that it only ever "worked" because no-one called
                   (pseudo)fork while the regexp engine had re-entered itself.
                 */
#ifdef PERL_OLD_COPY_ON_WRITE
                new_state->re_state_nrs = sv_dup (old_state->re_state_nrs, param);
#endif
                new_state->re_state_reg_magic = (MAGIC *) any_dup (old_state->re_state_reg_magic, proto_perl);
                new_state->re_state_reg_oldcurpm = (PMOP *) any_dup (old_state->re_state_reg_oldcurpm, proto_perl);
                new_state->re_state_reg_curpm = (PMOP *) any_dup (old_state->re_state_reg_curpm, proto_perl);
                new_state->re_state_reg_oldsaved = pv_dup (old_state->re_state_reg_oldsaved);
                new_state->re_state_reg_poscache = pv_dup (old_state->re_state_reg_poscache);
                new_state->re_state_reg_starttry = pv_dup (old_state->re_state_reg_starttry);
                break;
              }
#endif

            case SAVEt_COMPILE_WARNINGS:
              abort ();
#if 0
              ptr = POPPTR (ss, ix);
              TOPPTR (ss, ix) = DUP_WARNINGS ((STRLEN *) ptr);
              break;
#endif

            case SAVEt_PARSER:
              abort ();
#if 0
              ptr = POPPTR (ss, ix);
              TOPPTR (ss, ix) = parser_dup ((const yy_parser *) ptr, param);
              break;
#endif
            default:
              croak ("panic: ss_dup inconsistency (%" IVdf ")", (IV) type);
          }
      }
  }

  SvREFCNT_inc (nslot->defsv);
  SvREFCNT_inc (nslot->defav);
  SvREFCNT_inc (nslot->errsv);
  SvREFCNT_inc (nslot->irsgv);

  SvREFCNT_inc (nslot->defoutgv);
  SvREFCNT_inc (nslot->rs);
  SvREFCNT_inc (nslot->compcv);
  SvREFCNT_inc (nslot->diehook);
  SvREFCNT_inc (nslot->warnhook);

  SvREFCNT_inc (ncoro->startcv);
  SvREFCNT_inc (ncoro->args);
  SvREFCNT_inc (ncoro->except);

  return ncoro;
}