~ubuntu-branches/ubuntu/saucy/libcoro-perl/saucy-proposed : revision 12

14

#include "perliol.h"

15

16

#include "schmorp.h"

17

#include "ecb.h"

17

18

19

#include <stddef.h>

18

20

#include <stdio.h>

19

21

#include <errno.h>

20

22

#include <assert.h>

23

25

# define SVs_PADSTALE 0

24

26

#endif

25

27

26

#ifdef WIN32

28

#if defined(_WIN32)

27

29

# undef HAS_GETTIMEOFDAY

28

30

# undef setjmp

29

31

# undef longjmp

33

35

# include <inttypes.h> /* most portable stdint.h */

34

36

#endif

35

37

36

#ifdef HAVE_MMAP

38

#if HAVE_MMAP

37

39

# include <unistd.h>

38

40

# include <sys/mman.h>

39

41

# ifndef MAP_ANONYMOUS

63

65

/* the maximum number of idle cctx that will be pooled */

64

66

static int cctx_max_idle = 4;

65

67

68

#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)

69

# define HAS_SCOPESTACK_NAME 1

70

#endif

71

66

72

#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64

67

73

# undef CORO_STACKGUARD

68

74

#endif

88

94

89

95

#define IN_DESTRUCT PL_dirty

90

96

91

#if __GNUC__ >= 3

92

# define attribute(x) __attribute__(x)

93

# define expect(expr,value) __builtin_expect ((expr), (value))

94

# define INLINE static inline

95

#else

96

# define attribute(x)

97

# define expect(expr,value) (expr)

98

# define INLINE static

99

#endif

100

101

#define expect_false(expr) expect ((expr) != 0, 0)

102

#define expect_true(expr) expect ((expr) != 0, 1)

103

104

#define NOINLINE attribute ((noinline))

105

106

97

#include "CoroAPI.h"

107

98

#define GCoroAPI (&coroapi) /* very sneaky */

108

99

112

103

# endif

113

104

#endif

114

105

106

/* used in state.h */

107

#define VAR(name,type) VARx(name, PL_ ## name, type)

108

115

109

#ifdef __linux

116

110

# include <time.h> /* for timespec */

117

111

# include <syscall.h> /* for SYS_* */

128

122

/* we hijack an hopefully unused CV flag for our purposes */

129

123

#define CVf_SLF 0x4000

130

124

static OP *pp_slf (pTHX);

125

static void slf_destroy (pTHX_ struct coro *coro);

131

126

132

127

static U32 cctx_gen;

133

128

static size_t cctx_stacksize = CORO_STACKSIZE;

167

162

static struct coro_cctx *cctx_first;

168

163

static int cctx_count, cctx_idle;

169

164

170

enum {

165

enum

166

{

171

167

CC_MAPPED = 0x01,

172

168

CC_NOREUSE = 0x02, /* throw this away after tracing */

173

169

CC_TRACE = 0x04,

198

194

unsigned char flags;

199

195

} coro_cctx;

200

196

201

coro_cctx *cctx_current; /* the currently running cctx */

197

static coro_cctx *cctx_current; /* the currently running cctx */

202

198

203

199

/*****************************************************************************/

204

200

205

enum {

201

static MGVTBL coro_state_vtbl;

202

203

enum

204

{

206

205

CF_RUNNING = 0x0001, /* coroutine is running */

207

206

CF_READY = 0x0002, /* coroutine is ready */

208

207

CF_NEW = 0x0004, /* has never been switched to */

209

CF_DESTROYED = 0x0008, /* coroutine data has been freed */

208

CF_ZOMBIE = 0x0008, /* coroutine data has been freed */

210

209

CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */

210

CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */

211

};

212

213

/* the structure where most of the perl state is stored, overlaid on the cxstack */

214

typedef struct

215

{

216

SV *defsv;

217

AV *defav;

218

SV *errsv;

219

SV *irsgv;

220

HV *hinthv;

221

#define VAR(name,type) type name;

216

#define VARx(name,expr,type) type name;

222

217

# include "state.h"

223

#undef VAR

218

#undef VARx

224

219

} perl_slots;

225

220

221

/* how many context stack entries do we need for perl_slots */

226

222

#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))

227

223

228

224

/* this is a structure representing a perl-level coroutine */

229

struct coro {

225

struct coro

226

{

230

227

/* the C coroutine allocated to this perl coroutine, if any */

231

228

coro_cctx *cctx;

232

229

238

235

AV *mainstack;

239

236

perl_slots *slot; /* basically the saved sp */

240

237

241

CV *startcv; /* the CV to execute */

242

AV *args; /* data associated with this coroutine (initial args) */

243

int refcnt; /* coroutines are refcounted, yes */

244

int flags; /* CF_ flags */

245

HV *hv; /* the perl hash associated with this coro, if any */

246

void (*on_destroy)(pTHX_ struct coro *coro); /* for temporary use by xs in critical sections */

238

CV *startcv; /* the CV to execute */

239

AV *args; /* data associated with this coroutine (initial args) */

240

int flags; /* CF_ flags */

241

HV *hv; /* the perl hash associated with this coro, if any */

247

242

248

243

/* statistics */

249

244

int usecount; /* number of transfers to this coro */

250

245

251

246

/* coro process data */

252

247

int prio;

253

SV *except; /* exception to be thrown */

254

SV *rouse_cb;

248

SV *except; /* exception to be thrown */

249

SV *rouse_cb; /* last rouse callback */

250

AV *on_destroy; /* callbacks or coros to notify on destroy */

251

AV *status; /* the exit status list */

255

252

256

253

/* async_pool */

257

254

SV *saved_deffh;

277

274

278

275

/* the following variables are effectively part of the perl context */

279

276

/* and get copied between struct coro and these variables */

280

/* the mainr easonw e don't support windows process emulation */

277

/* the main reason we don't support windows process emulation */

281

278

static struct CoroSLF slf_frame; /* the current slf frame */

282

279

283

280

/** Coro ********************************************************************/

293

290

static SV *coro_current;

294

291

static SV *coro_readyhook;

295

292

static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */

296

static CV *cv_coro_run, *cv_coro_terminate;

293

static CV *cv_coro_run;

297

294

static struct coro *coro_first;

298

295

#define coro_nready coroapi.nready

299

296

297

/** JIT *********************************************************************/

298

299

#if CORO_JIT

300

/* APPLE doesn't have HAVE_MMAP though */

301

#define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)

302

#ifndef CORO_JIT_TYPE

303

#if __x86_64 && CORO_JIT_UNIXY

304

#define CORO_JIT_TYPE "amd64-unix"

305

#elif __i386 && CORO_JIT_UNIXY

306

#define CORO_JIT_TYPE "x86-unix"

307

#endif

308

#endif

309

#endif

310

311

#if !defined(CORO_JIT_TYPE) || !HAVE_MMAP

312

#undef CORO_JIT

313

#endif

314

315

#if CORO_JIT

316

typedef void (*load_save_perl_slots_type)(perl_slots *);

317

static load_save_perl_slots_type load_perl_slots, save_perl_slots;

318

#endif

319

300

320

/** Coro::Select ************************************************************/

301

321

302

322

static OP *(*coro_old_pp_sselect) (pTHX);

321

341

322

342

#ifdef HAS_GETTIMEOFDAY

323

343

324

static void

344

ecb_inline void

325

345

coro_u2time (pTHX_ UV ret[2])

326

346

{

327

347

struct timeval tv;

331

351

ret [1] = tv.tv_usec;

332

352

}

333

353

334

static double

335

coro_nvtime ()

354

ecb_inline double

355

coro_nvtime (void)

336

356

{

337

357

struct timeval tv;

338

358

gettimeofday (&tv, 0);

340

360

return tv.tv_sec + tv.tv_usec * 1e-6;

341

361

}

342

362

343

static void

363

ecb_inline void

344

364

time_init (pTHX)

345

365

{

346

366

nvtime = coro_nvtime;

349

369

350

370

#else

351

371

352

static void

372

ecb_inline void

353

373

time_init (pTHX)

354

374

{

355

375

SV **svp;

358

378

359

379

svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);

360

380

361

if (!svp) croak ("Time::HiRes is required, but missing.");

362

if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");

381

if (!svp) croak ("Time::HiRes is required, but missing. Caught");

382

if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");

363

383

364

384

nvtime = INT2PTR (double (*)(), SvIV (*svp));

365

385

371

391

372

392

/** lowlevel stuff **********************************************************/

373

393

374

static SV *

394

static SV * ecb_noinline

375

395

coro_get_sv (pTHX_ const char *name, int create)

376

396

{

377

397

#if PERL_VERSION_ATLEAST (5,10,0)

381

401

return get_sv (name, create);

382

402

}

383

403

384

static AV *

404

static AV * ecb_noinline

385

405

coro_get_av (pTHX_ const char *name, int create)

386

406

{

387

407

#if PERL_VERSION_ATLEAST (5,10,0)

391

411

return get_av (name, create);

392

412

}

393

413

394

static HV *

414

static HV * ecb_noinline

395

415

coro_get_hv (pTHX_ const char *name, int create)

396

416

{

397

417

#if PERL_VERSION_ATLEAST (5,10,0)

401

421

return get_hv (name, create);

402

422

}

403

423

404

INLINE void

405

coro_times_update ()

424

ecb_inline void

425

coro_times_update (void)

406

426

{

407

427

#ifdef coro_clock_gettime

408

428

struct timespec ts;

424

444

#endif

425

445

}

426

446

427

INLINE void

447

ecb_inline void

428

448

coro_times_add (struct coro *c)

429

449

{

430

450

c->t_real [1] += time_real [1];

436

456

c->t_cpu [0] += time_cpu [0];

437

457

}

438

458

439

INLINE void

459

ecb_inline void

440

460

coro_times_sub (struct coro *c)

441

461

{

442

462

if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }

454

474

#define CORO_MAGIC_type_cv 26

455

475

#define CORO_MAGIC_type_state PERL_MAGIC_ext

456

476

457

#define CORO_MAGIC_NN(sv, type) \

458

(expect_true (SvMAGIC (sv)->mg_type == type) \

459

? SvMAGIC (sv) \

477

#define CORO_MAGIC_NN(sv, type) \

478

(ecb_expect_true (SvMAGIC (sv)->mg_type == type) \

479

? SvMAGIC (sv) \

460

480

: mg_find (sv, type))

461

481

462

#define CORO_MAGIC(sv, type) \

463

(expect_true (SvMAGIC (sv)) \

464

? CORO_MAGIC_NN (sv, type) \

482

#define CORO_MAGIC(sv, type) \

483

(ecb_expect_true (SvMAGIC (sv)) \

484

? CORO_MAGIC_NN (sv, type) \

465

485

: 0)

466

486

467

487

#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)

468

488

#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)

469

489

470

INLINE struct coro *

490

ecb_inline MAGIC *

491

SvSTATEhv_p (pTHX_ SV *coro)

492

{

493

MAGIC *mg;

494

495

if (ecb_expect_true (

496

SvTYPE (coro) == SVt_PVHV

497

&& (mg = CORO_MAGIC_state (coro))

498

&& mg->mg_virtual == &coro_state_vtbl

499

))

500

return mg;

501

502

return 0;

503

}

504

505

ecb_inline struct coro *

471

506

SvSTATE_ (pTHX_ SV *coro)

472

507

{

473

HV *stash;

474

508

MAGIC *mg;

475

509

476

510

if (SvROK (coro))

477

511

coro = SvRV (coro);

478

512

479

if (expect_false (SvTYPE (coro) != SVt_PVHV))

513

mg = SvSTATEhv_p (aTHX_ coro);

514

if (!mg)

480

515

croak ("Coro::State object required");

481

516

482

stash = SvSTASH (coro);

483

if (expect_false (stash != coro_stash && stash != coro_state_stash))

484

{

485

/* very slow, but rare, check */

486

if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))

487

croak ("Coro::State object required");

488

}

489

490

mg = CORO_MAGIC_state (coro);

491

517

return (struct coro *)mg->mg_ptr;

492

518

}

493

519

500

526

/*****************************************************************************/

501

527

/* padlist management and caching */

502

528

503

static AV *

529

ecb_inline AV *

504

530

coro_derive_padlist (pTHX_ CV *cv)

505

531

{

506

532

AV *padlist = CvPADLIST (cv);

522

548

return newpadlist;

523

549

}

524

550

525

static void

551

ecb_inline void

526

552

free_padlist (pTHX_ AV *padlist)

527

553

{

528

554

/* may be during global destruction */

575

601

};

576

602

577

603

/* the next two functions merely cache the padlists */

578

static void

604

ecb_inline void

579

605

get_padlist (pTHX_ CV *cv)

580

606

{

581

607

MAGIC *mg = CORO_MAGIC_cv (cv);

582

608

AV *av;

583

609

584

if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))

610

if (ecb_expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))

585

611

CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];

586

612

else

587

613

{

598

624

}

599

625

}

600

626

601

static void

627

ecb_inline void

602

628

put_padlist (pTHX_ CV *cv)

603

629

{

604

630

MAGIC *mg = CORO_MAGIC_cv (cv);

605

631

AV *av;

606

632

607

if (expect_false (!mg))

633

if (ecb_expect_false (!mg))

608

634

mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);

609

635

610

636

av = (AV *)mg->mg_obj;

611

637

612

if (expect_false (AvFILLp (av) >= AvMAX (av)))

638

if (ecb_expect_false (AvFILLp (av) >= AvMAX (av)))

613

639

av_extend (av, AvFILLp (av) + 1);

614

640

615

641

AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);

664

690

}

665

691

}

666

692

667

#define SWAP_SVS(coro) \

668

if (expect_false ((coro)->swap_sv)) \

693

#define SWAP_SVS(coro) \

694

if (ecb_expect_false ((coro)->swap_sv)) \

669

695

swap_svs (aTHX_ (coro))

670

696

671

697

static void

679

705

680

706

PL_mainstack = c->mainstack;

681

707

682

GvSV (PL_defgv) = slot->defsv;

683

GvAV (PL_defgv) = slot->defav;

684

GvSV (PL_errgv) = slot->errsv;

685

GvSV (irsgv) = slot->irsgv;

686

GvHV (PL_hintgv) = slot->hinthv;

687

688

#define VAR(name,type) PL_ ## name = slot->name;

708

#if CORO_JIT

709

load_perl_slots (slot);

710

#else

711

#define VARx(name,expr,type) expr = slot->name;

689

712

# include "state.h"

690

#undef VAR

713

#undef VARx

714

#endif

691

715

692

716

{

693

717

dSP;

695

719

CV *cv;

696

720

697

721

/* now do the ugly restore mess */

698

while (expect_true (cv = (CV *)POPs))

722

while (ecb_expect_true (cv = (CV *)POPs))

699

723

{

700

724

put_padlist (aTHX_ cv); /* mark this padlist as available */

701

725

CvDEPTH (cv) = PTR2IV (POPs);

708

732

slf_frame = c->slf_frame;

709

733

CORO_THROW = c->except;

710

734

711

if (expect_false (enable_times))

735

if (ecb_expect_false (enable_times))

712

736

{

713

if (expect_false (!times_valid))

737

if (ecb_expect_false (!times_valid))

714

738

coro_times_update ();

715

739

716

740

coro_times_sub (c);

717

741

}

718

742

719

if (expect_false (c->on_enter))

743

if (ecb_expect_false (c->on_enter))

720

744

{

721

745

int i;

722

746

732

756

{

733

757

SWAP_SVS (c);

734

758

735

if (expect_false (c->on_leave))

759

if (ecb_expect_false (c->on_leave))

736

760

{

737

761

int i;

738

762

742

766

743

767

times_valid = 0;

744

768

745

if (expect_false (enable_times))

769

if (ecb_expect_false (enable_times))

746

770

{

747

771

coro_times_update (); times_valid = 1;

748

772

coro_times_add (c);

766

790

/* this loop was inspired by pp_caller */

767

791

for (;;)

768

792

{

769

while (expect_true (cxix >= 0))

793

while (ecb_expect_true (cxix >= 0))

770

794

{

771

795

PERL_CONTEXT *cx = &ccstk[cxix--];

772

796

773

if (expect_true (CxTYPE (cx) == CXt_SUB) || expect_false (CxTYPE (cx) == CXt_FORMAT))

797

if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT))

774

798

{

775

799

CV *cv = cx->blk_sub.cv;

776

800

777

if (expect_true (CvDEPTH (cv)))

801

if (ecb_expect_true (CvDEPTH (cv)))

778

802

{

779

803

EXTEND (SP, 3);

780

804

PUSHs ((SV *)CvPADLIST (cv));

787

811

}

788

812

}

789

813

790

if (expect_true (top_si->si_type == PERLSI_MAIN))

814

if (ecb_expect_true (top_si->si_type == PERLSI_MAIN))

791

815

break;

792

816

793

817

top_si = top_si->si_prev;

799

823

}

800

824

801

825

/* allocate some space on the context stack for our purposes */

802

/* we manually unroll here, as usually 2 slots is enough */

803

if (SLOT_COUNT >= 1) CXINC;

804

if (SLOT_COUNT >= 2) CXINC;

805

if (SLOT_COUNT >= 3) CXINC;

806

{

807

unsigned int i;

808

for (i = 3; i < SLOT_COUNT; ++i)

809

CXINC;

810

}

811

cxstack_ix -= SLOT_COUNT; /* undo allocation */

826

if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))

827

{

828

unsigned int i;

829

830

for (i = 0; i < SLOT_COUNT; ++i)

831

CXINC;

832

833

cxstack_ix -= SLOT_COUNT; /* undo allocation */

834

}

812

835

813

836

c->mainstack = PL_mainstack;

814

837

815

838

{

816

839

perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);

817

840

818

slot->defav = GvAV (PL_defgv);

819

slot->defsv = DEFSV;

820

slot->errsv = ERRSV;

821

slot->irsgv = GvSV (irsgv);

822

slot->hinthv = GvHV (PL_hintgv);

823

824

#define VAR(name,type) slot->name = PL_ ## name;

841

#if CORO_JIT

842

save_perl_slots (slot);

843

#else

844

#define VARx(name,expr,type) slot->name = expr;

825

845

# include "state.h"

826

#undef VAR

846

#undef VARx

847

#endif

827

848

}

828

849

}

829

850

839

860

static void

840

861

coro_init_stacks (pTHX)

841

862

{

842

PL_curstackinfo = new_stackinfo(32, 8);

863

PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */

843

864

PL_curstackinfo->si_type = PERLSI_MAIN;

844

865

PL_curstack = PL_curstackinfo->si_stack;

845

866

PL_mainstack = PL_curstack; /* remember in case we switch stacks */

864

885

New(54,PL_scopestack,8,I32);

865

886

PL_scopestack_ix = 0;

866

887

PL_scopestack_max = 8;

888

#if HAS_SCOPESTACK_NAME

889

New(54,PL_scopestack_name,8,const char*);

890

#endif

867

891

868

892

New(54,PL_savestack,24,ANY);

869

893

PL_savestack_ix = 0;

901

925

Safefree (PL_tmps_stack);

902

926

Safefree (PL_markstack);

903

927

Safefree (PL_scopestack);

928

#if HAS_SCOPESTACK_NAME

929

Safefree (PL_scopestack_name);

930

#endif

904

931

Safefree (PL_savestack);

905

932

#if !PERL_VERSION_ATLEAST (5,10,0)

906

933

Safefree (PL_retstack);

956

983

/*

957

984

* This overrides the default magic get method of %SIG elements.

958

985

* The original one doesn't provide for reading back of PL_diehook/PL_warnhook

959

* and instead of trying to save and restore the hash elements, we just provide

960

* readback here.

986

* and instead of trying to save and restore the hash elements (extremely slow),

987

* we just provide our own readback here.

961

988

*/

962

static int

989

static int ecb_cold

963

990

coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)

964

991

{

965

992

const char *s = MgPV_nolen_const (mg);

981

1008

return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;

982

1009

}

983

1010

984

static int

1011

static int ecb_cold

985

1012

coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)

986

1013

{

987

1014

const char *s = MgPV_nolen_const (mg);

1005

1032

return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;

1006

1033

}

1007

1034

1008

static int

1035

static int ecb_cold

1009

1036

coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)

1010

1037

{

1011

1038

const char *s = MgPV_nolen_const (mg);

1050

1077

1051

1078

static UNOP init_perl_op;

1052

1079

1053

static void NOINLINE /* noinline to keep it out of the transfer fast path */

1080

ecb_noinline static void /* noinline to keep it out of the transfer fast path */

1054

1081

init_perl (pTHX_ struct coro *coro)

1055

1082

{

1056

1083

/*

1075

1102

PL_hints = 0;

1076

1103

1077

1104

/* recreate the die/warn hooks */

1078

PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );

1079

PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);

1105

PL_diehook = SvREFCNT_inc (rv_diehook);

1106

PL_warnhook = SvREFCNT_inc (rv_warnhook);

1080

1107

1081

1108

GvSV (PL_defgv) = newSV (0);

1082

1109

GvAV (PL_defgv) = coro->args; coro->args = 0;

1107

1134

*/

1108

1135

slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */

1109

1136

slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */

1137

slf_frame.destroy = 0;

1110

1138

1111

1139

/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */

1112

1140

init_perl_op.op_next = PL_op;

1121

1149

1122

1150

SWAP_SVS (coro);

1123

1151

1124

if (expect_false (enable_times))

1152

if (ecb_expect_false (enable_times))

1125

1153

{

1126

1154

coro_times_update ();

1127

1155

coro_times_sub (coro);

1155

1183

SV *svf [9];

1156

1184

1157

1185

{

1158

struct coro *current = SvSTATE_current;

1186

SV *old_current = SvRV (coro_current);

1187

struct coro *current = SvSTATE (old_current);

1159

1188

1160

1189

assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));

1161

1190

1162

1191

save_perl (aTHX_ current);

1192

1193

/* this will cause transfer_check to croak on block*/

1194

SvRV_set (coro_current, (SV *)coro->hv);

1195

1163

1196

load_perl (aTHX_ coro);

1164

1197

1165

1198

coro_unwind_stacks (aTHX);

1166

coro_destruct_stacks (aTHX);

1167

1199

1168

1200

/* restore swapped sv's */

1169

1201

SWAP_SVS (coro);

1170

1202

1171

// now save some sv's to be free'd later

1203

coro_destruct_stacks (aTHX);

1204

1205

/* now save some sv's to be free'd later */

1172

1206

svf [0] = GvSV (PL_defgv);

1173

1207

svf [1] = (SV *)GvAV (PL_defgv);

1174

1208

svf [2] = GvSV (PL_errgv);

1180

1214

svf [8] = PL_warnhook;

1181

1215

assert (9 == sizeof (svf) / sizeof (*svf));

1182

1216

1217

SvRV_set (coro_current, old_current);

1218

1183

1219

load_perl (aTHX_ current);

1184

1220

}

1185

1221

1196

1232

}

1197

1233

}

1198

1234

1199

INLINE void

1235

ecb_inline void

1200

1236

free_coro_mortal (pTHX)

1201

1237

{

1202

if (expect_true (coro_mortal))

1238

if (ecb_expect_true (coro_mortal))

1203

1239

{

1204

SvREFCNT_dec (coro_mortal);

1240

SvREFCNT_dec ((SV *)coro_mortal);

1205

1241

coro_mortal = 0;

1206

1242

}

1207

1243

}

1344

1380

}

1345

1381

1346

1382

/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */

1347

static void NOINLINE

1383

static void ecb_noinline

1348

1384

cctx_prepare (pTHX)

1349

1385

{

1350

1386

PL_top_env = &PL_start_env;

1365

1401

}

1366

1402

1367

1403

/* the tail of transfer: execute stuff we can only do after a transfer */

1368

INLINE void

1404

ecb_inline void

1369

1405

transfer_tail (pTHX)

1370

1406

{

1371

1407

free_coro_mortal (aTHX);

1419

1455

}

1420

1456

1421

1457

static coro_cctx *

1422

cctx_new ()

1458

cctx_new (void)

1423

1459

{

1424

1460

coro_cctx *cctx;

1425

1461

1435

1471

1436

1472

/* create a new cctx only suitable as source */

1437

1473

static coro_cctx *

1438

cctx_new_empty ()

1474

cctx_new_empty (void)

1439

1475

{

1440

1476

coro_cctx *cctx = cctx_new ();

1441

1477

1447

1483

1448

1484

/* create a new cctx suitable as destination/running a perl interpreter */

1449

1485

static coro_cctx *

1450

cctx_new_run ()

1486

cctx_new_run (void)

1451

1487

{

1452

1488

coro_cctx *cctx = cctx_new ();

1453

1489

void *stack_start;

1456

1492

#if HAVE_MMAP

1457

1493

cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;

1458

1494

/* mmap supposedly does allocate-on-write for us */

1459

cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);

1495

cctx->sptr = mmap (0, cctx->ssize, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_ANONYMOUS, 0, 0);

1460

1496

1461

1497

if (cctx->sptr != (void *)-1)

1462

1498

{

1498

1534

if (!cctx)

1499

1535

return;

1500

1536

1501

assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));//D temporary?

1537

assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));

1502

1538

1503

1539

--cctx_count;

1504

1540

coro_destroy (&cctx->cctx);

1527

1563

static coro_cctx *

1528

1564

cctx_get (pTHX)

1529

1565

{

1530

while (expect_true (cctx_first))

1566

while (ecb_expect_true (cctx_first))

1531

1567

{

1532

1568

coro_cctx *cctx = cctx_first;

1533

1569

cctx_first = cctx->next;

1534

1570

--cctx_idle;

1535

1571

1536

if (expect_true (!CCTX_EXPIRED (cctx)))

1572

if (ecb_expect_true (!CCTX_EXPIRED (cctx)))

1537

1573

return cctx;

1538

1574

1539

1575

cctx_destroy (cctx);

1548

1584

assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));

1549

1585

1550

1586

/* free another cctx if overlimit */

1551

if (expect_false (cctx_idle >= cctx_max_idle))

1587

if (ecb_expect_false (cctx_idle >= cctx_max_idle))

1552

1588

{

1553

1589

coro_cctx *first = cctx_first;

1554

1590

cctx_first = first->next;

1569

1605

{

1570

1606

/* TODO: throwing up here is considered harmful */

1571

1607

1572

if (expect_true (prev != next))

1608

if (ecb_expect_true (prev != next))

1573

1609

{

1574

if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))

1610

if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))

1575

1611

croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");

1576

1612

1577

if (expect_false (next->flags & (CF_RUNNING | CF_DESTROYED | CF_SUSPENDED)))

1613

if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))

1578

1614

croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");

1579

1615

1580

1616

#if !PERL_VERSION_ATLEAST (5,10,0)

1581

if (expect_false (PL_lex_state != LEX_NOTPARSING))

1617

if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))

1582

1618

croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");

1583

1619

#endif

1584

1620

}

1585

1621

}

1586

1622

1587

1623

/* always use the TRANSFER macro */

1588

static void NOINLINE /* noinline so we have a fixed stackframe */

1624

static void ecb_noinline /* noinline so we have a fixed stackframe */

1589

1625

transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)

1590

1626

{

1591

1627

dSTACKLEVEL;

1592

1628

1593

1629

/* sometimes transfer is only called to set idle_sp */

1594

if (expect_false (!prev))

1630

if (ecb_expect_false (!prev))

1595

1631

{

1596

1632

cctx_current->idle_sp = STACKLEVEL;

1597

1633

assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */

1598

1634

}

1599

else if (expect_true (prev != next))

1635

else if (ecb_expect_true (prev != next))

1600

1636

{

1601

1637

coro_cctx *cctx_prev;

1602

1638

1603

if (expect_false (prev->flags & CF_NEW))

1639

if (ecb_expect_false (prev->flags & CF_NEW))

1604

1640

{

1605

1641

/* create a new empty/source context */

1606

1642

prev->flags &= ~CF_NEW;

1613

1649

/* first get rid of the old state */

1614

1650

save_perl (aTHX_ prev);

1615

1651

1616

if (expect_false (next->flags & CF_NEW))

1652

if (ecb_expect_false (next->flags & CF_NEW))

1617

1653

{

1618

1654

/* need to start coroutine */

1619

1655

next->flags &= ~CF_NEW;

1624

1660

load_perl (aTHX_ next);

1625

1661

1626

1662

/* possibly untie and reuse the cctx */

1627

if (expect_true (

1663

if (ecb_expect_true (

1628

1664

cctx_current->idle_sp == STACKLEVEL

1629

1665

&& !(cctx_current->flags & CC_TRACE)

1630

1666

&& !force_cctx

1635

1671

1636

1672

/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */

1637

1673

/* without this the next cctx_get might destroy the running cctx while still in use */

1638

if (expect_false (CCTX_EXPIRED (cctx_current)))

1639

if (expect_true (!next->cctx))

1674

if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))

1675

if (ecb_expect_true (!next->cctx))

1640

1676

next->cctx = cctx_get (aTHX);

1641

1677

1642

1678

cctx_put (cctx_current);

1647

1683

++next->usecount;

1648

1684

1649

1685

cctx_prev = cctx_current;

1650

cctx_current = expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);

1686

cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);

1651

1687

1652

1688

next->cctx = 0;

1653

1689

1654

if (expect_false (cctx_prev != cctx_current))

1690

if (ecb_expect_false (cctx_prev != cctx_current))

1655

1691

{

1656

1692

cctx_prev->top_env = PL_top_env;

1657

1693

PL_top_env = cctx_current->top_env;

1667

1703

1668

1704

/** high level stuff ********************************************************/

1669

1705

1670

static int

1706

/* this function is actually Coro, not Coro::State, but we call it from here */

1707

/* because it is convenient - but it hasn't been declared yet for that reason */

1708

static void

1709

coro_call_on_destroy (pTHX_ struct coro *coro);

1710

1711

static void

1671

1712

coro_state_destroy (pTHX_ struct coro *coro)

1672

1713

{

1673

if (coro->flags & CF_DESTROYED)

1674

return 0;

1675

1676

if (coro->on_destroy && !PL_dirty)

1677

coro->on_destroy (aTHX_ coro);

1678

1679

coro->flags |= CF_DESTROYED;

1714

if (coro->flags & CF_ZOMBIE)

1715

return;

1716

1717

slf_destroy (aTHX_ coro);

1718

1719

coro->flags |= CF_ZOMBIE;

1680

1720

1681

1721

if (coro->flags & CF_READY)

1682

1722

{

1687

1727

else

1688

1728

coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */

1689

1729

1730

if (coro->next) coro->next->prev = coro->prev;

1731

if (coro->prev) coro->prev->next = coro->next;

1732

if (coro == coro_first) coro_first = coro->next;

1733

1690

1734

if (coro->mainstack

1691

1735

&& coro->mainstack != main_mainstack

1692

1736

&& coro->slot

1693

1737

&& !PL_dirty)

1694

1738

destroy_perl (aTHX_ coro);

1695

1739

1696

if (coro->next) coro->next->prev = coro->prev;

1697

if (coro->prev) coro->prev->next = coro->next;

1698

if (coro == coro_first) coro_first = coro->next;

1699

1700

1740

cctx_destroy (coro->cctx);

1701

1741

SvREFCNT_dec (coro->startcv);

1702

1742

SvREFCNT_dec (coro->args);

1703

1743

SvREFCNT_dec (coro->swap_sv);

1704

1744

SvREFCNT_dec (CORO_THROW);

1705

1745

1706

return 1;

1746

coro_call_on_destroy (aTHX_ coro);

1747

1748

/* more destruction mayhem in coro_state_free */

1707

1749

}

1708

1750

1709

1751

static int

1712

1754

struct coro *coro = (struct coro *)mg->mg_ptr;

1713

1755

mg->mg_ptr = 0;

1714

1756

1715

coro->hv = 0;

1757

coro_state_destroy (aTHX_ coro);

1758

SvREFCNT_dec (coro->on_destroy);

1759

SvREFCNT_dec (coro->status);

1716

1760

1717

if (--coro->refcnt < 0)

1718

{

1719

coro_state_destroy (aTHX_ coro);

1720

Safefree (coro);

1721

}

1761

Safefree (coro);

1722

1762

1723

1763

return 0;

1724

1764

}

1725

1765

1726

static int

1766

static int ecb_cold

1727

1767

coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)

1728

1768

{

1729

struct coro *coro = (struct coro *)mg->mg_ptr;

1730

1731

++coro->refcnt;

1769

/* called when perl clones the current process the slow way (windows process emulation) */

1770

/* WE SIMply nuke the pointers in the copy, causing perl to croak */

1771

mg->mg_ptr = 0;

1772

mg->mg_virtual = 0;

1732

1773

1733

1774

return 0;

1734

1775

}

1763

1804

1764

1805

/** Coro ********************************************************************/

1765

1806

1766

INLINE void

1807

ecb_inline void

1767

1808

coro_enq (pTHX_ struct coro *coro)

1768

1809

{

1769

1810

struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];

1775

1816

ready [1] = coro;

1776

1817

}

1777

1818

1778

INLINE struct coro *

1819

ecb_inline struct coro *

1779

1820

coro_deq (pTHX)

1780

1821

{

1781

1822

int prio;

1838

1879

}

1839

1880

1840

1881

/* expects to own a reference to next->hv */

1841

INLINE void

1882

ecb_inline void

1842

1883

prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)

1843

1884

{

1844

1885

SV *prev_sv = SvRV (coro_current);

1861

1902

{

1862

1903

struct coro *next = coro_deq (aTHX);

1863

1904

1864

if (expect_true (next))

1905

if (ecb_expect_true (next))

1865

1906

{

1866

1907

/* cannot transfer to destroyed coros, skip and look for next */

1867

if (expect_false (next->flags & (CF_DESTROYED | CF_SUSPENDED)))

1908

if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))

1868

1909

SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */

1869

1910

else

1870

1911

{

1907

1948

}

1908

1949

}

1909

1950

1910

INLINE void

1951

ecb_inline void

1911

1952

prepare_cede (pTHX_ struct coro_transfer_args *ta)

1912

1953

{

1913

1954

api_ready (aTHX_ coro_current);

1914

1955

prepare_schedule (aTHX_ ta);

1915

1956

}

1916

1957

1917

INLINE void

1958

ecb_inline void

1918

1959

prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)

1919

1960

{

1920

1961

SV *prev = SvRV (coro_current);

1954

1995

1955

1996

prepare_cede (aTHX_ &ta);

1956

1997

1957

if (expect_true (ta.prev != ta.next))

1998

if (ecb_expect_true (ta.prev != ta.next))

1958

1999

{

1959

2000

TRANSFER (ta, 1);

1960

2001

return 1;

2007

2048

}

2008

2049

2009

2050

static void

2051

coro_push_av (pTHX_ AV *av, I32 gimme_v)

2052

{

2053

if (AvFILLp (av) >= 0 && gimme_v != G_VOID)

2054

{

2055

dSP;

2056

2057

if (gimme_v == G_SCALAR)

2058

XPUSHs (AvARRAY (av)[AvFILLp (av)]);

2059

else

2060

{

2061

int i;

2062

EXTEND (SP, AvFILLp (av) + 1);

2063

2064

for (i = 0; i <= AvFILLp (av); ++i)

2065

PUSHs (AvARRAY (av)[i]);

2066

}

2067

2068

PUTBACK;

2069

}

2070

}

2071

2072

static void

2073

coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)

2074

{

2075

if (!coro->on_destroy)

2076

coro->on_destroy = newAV ();

2077

2078

av_push (coro->on_destroy, cb);

2079

}

2080

2081

static void

2082

slf_destroy_join (pTHX_ struct CoroSLF *frame)

2083

{

2084

SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);

2085

}

2086

2087

static int

2088

slf_check_join (pTHX_ struct CoroSLF *frame)

2089

{

2090

struct coro *coro = (struct coro *)frame->data;

2091

2092

if (!coro->status)

2093

return 1;

2094

2095

frame->destroy = 0;

2096

2097

coro_push_av (aTHX_ coro->status, GIMME_V);

2098

2099

SvREFCNT_dec ((SV *)coro->hv);

2100

2101

return 0;

2102

}

2103

2104

static void

2105

slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)

2106

{

2107

struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);

2108

2109

if (items > 1)

2110

croak ("join called with too many arguments");

2111

2112

if (coro->status)

2113

frame->prepare = prepare_nop;

2114

else

2115

{

2116

coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));

2117

frame->prepare = prepare_schedule;

2118

}

2119

2120

frame->check = slf_check_join;

2121

frame->destroy = slf_destroy_join;

2122

frame->data = (void *)coro;

2123

SvREFCNT_inc (coro->hv);

2124

}

2125

2126

static void

2010

2127

coro_call_on_destroy (pTHX_ struct coro *coro)

2011

2128

{

2012

SV **on_destroyp = hv_fetch (coro->hv, "_on_destroy", sizeof ("_on_destroy") - 1, 0);

2013

SV **statusp = hv_fetch (coro->hv, "_status", sizeof ("_status") - 1, 0);

2014

2015

if (on_destroyp)

2129

AV *od = coro->on_destroy;

2130

2131

if (!od)

2132

return;

2133

2134

while (AvFILLp (od) >= 0)

2016

2135

{

2017

AV *on_destroy = (AV *)SvRV (*on_destroyp);

2136

SV *cb = sv_2mortal (av_pop (od));

2018

2137

2019

while (AvFILLp (on_destroy) >= 0)

2138

/* coro hv's (and only hv's at the moment) are supported as well */

2139

if (SvSTATEhv_p (aTHX_ cb))

2140

api_ready (aTHX_ cb);

2141

else

2020

2142

{

2021

2143

dSP; /* don't disturb outer sp */

2022

SV *cb = av_pop (on_destroy);

2023

2024

2144

PUSHMARK (SP);

2025

2145

2026

if (statusp)

2146

if (coro->status)

2027

2147

{

2028

int i;

2029

AV *status = (AV *)SvRV (*statusp);

2030

EXTEND (SP, AvFILLp (status) + 1);

2031

2032

for (i = 0; i <= AvFILLp (status); ++i)

2033

PUSHs (AvARRAY (status)[i]);

2148

PUTBACK;

2149

coro_push_av (aTHX_ coro->status, G_ARRAY);

2150

SPAGAIN;

2034

2151

}

2035

2152

2036

2153

PUTBACK;

2037

call_sv (sv_2mortal (cb), G_VOID | G_DISCARD);

2154

call_sv (cb, G_VOID | G_DISCARD);

2038

2155

}

2039

2156

}

2040

2157

}

2041

2158

2042

2159

static void

2043

slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)

2160

coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)

2044

2161

{

2045

int i;

2046

HV *hv = (HV *)SvRV (coro_current);

2047

AV *av = newAV ();

2162

AV *av;

2163

2164

if (coro->status)

2165

{

2166

av = coro->status;

2167

av_clear (av);

2168

}

2169

else

2170

av = coro->status = newAV ();

2048

2171

2049

2172

/* items are actually not so common, so optimise for this case */

2050

2173

if (items)

2051

2174

{

2175

int i;

2176

2052

2177

av_extend (av, items - 1);

2053

2178

2054

2179

for (i = 0; i < items; ++i)

2055

2180

av_push (av, SvREFCNT_inc_NN (arg [i]));

2056

2181

}

2057

2058

hv_store (hv, "_status", sizeof ("_status") - 1, newRV_noinc ((SV *)av), 0);

2059

2060

av_push (av_destroy, (SV *)newRV_inc ((SV *)hv)); /* RVinc for perl */

2182

}

2183

2184

static void

2185

slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)

2186

{

2187

av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */

2061

2188

api_ready (aTHX_ sv_manager);

2062

2189

2063

2190

frame->prepare = prepare_schedule;

2068

2195

/*coro_unwind_stacks (aTHX);*/

2069

2196

}

2070

2197

2198

static void

2199

slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)

2200

{

2201

HV *coro_hv = (HV *)SvRV (coro_current);

2202

2203

coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);

2204

slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);

2205

}

2206

2207

static void

2208

slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)

2209

{

2210

HV *coro_hv;

2211

struct coro *coro;

2212

2213

if (items <= 0)

2214

croak ("Coro::cancel called without coro object,");

2215

2216

coro = SvSTATE (arg [0]);

2217

coro_hv = coro->hv;

2218

2219

coro_set_status (aTHX_ coro, arg + 1, items - 1);

2220

2221

if (ecb_expect_false (coro->flags & CF_NOCANCEL))

2222

{

2223

/* coro currently busy cancelling something, so just notify it */

2224

coro->slf_frame.data = (void *)coro;

2225

2226

frame->prepare = prepare_nop;

2227

frame->check = slf_check_nop;

2228

}

2229

else if (coro_hv == (HV *)SvRV (coro_current))

2230

{

2231

/* cancelling the current coro is allowed, and equals terminate */

2232

slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);

2233

}

2234

else

2235

{

2236

struct coro *self = SvSTATE_current;

2237

2238

/* otherwise we cancel directly, purely for speed reasons

2239

* unfortunately, this requires some magic trickery, as

2240

* somebody else could cancel us, so we have to fight the cancellation.

2241

* this is ugly, and hopefully fully worth the extra speed.

2242

* besides, I can't get the slow-but-safe version working...

2243

*/

2244

slf_frame.data = 0;

2245

self->flags |= CF_NOCANCEL;

2246

coro_state_destroy (aTHX_ coro);

2247

self->flags &= ~CF_NOCANCEL;

2248

2249

if (slf_frame.data)

2250

{

2251

/* while we were busy we have been cancelled, so terminate */

2252

slf_init_terminate_cancel_common (aTHX_ frame, self->hv);

2253

}

2254

else

2255

{

2256

frame->prepare = prepare_nop;

2257

frame->check = slf_check_nop;

2258

}

2259

}

2260

}

2261

2262

static int

2263

slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)

2264

{

2265

frame->prepare = 0;

2266

coro_unwind_stacks (aTHX);

2267

2268

slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));

2269

2270

return 1;

2271

}

2272

2273

static int

2274

safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)

2275

{

2276

if (coro->cctx)

2277

croak ("coro inside C callback, unable to cancel at this time, caught");

2278

2279

if (coro->flags & CF_NEW)

2280

{

2281

coro_set_status (aTHX_ coro, arg, items);

2282

coro_state_destroy (aTHX_ coro);

2283

}

2284

else

2285

{

2286

if (!coro->slf_frame.prepare)

2287

croak ("coro outside an SLF function, unable to cancel at this time, caught");

2288

2289

slf_destroy (aTHX_ coro);

2290

2291

coro_set_status (aTHX_ coro, arg, items);

2292

coro->slf_frame.prepare = prepare_nop;

2293

coro->slf_frame.check = slf_check_safe_cancel;

2294

2295

api_ready (aTHX_ (SV *)coro->hv);

2296

}

2297

2298

return 1;

2299

}

2300

2071

2301

/*****************************************************************************/

2072

2302

/* async pool handler */

2073

2303

2106

2336

HV *hv = (HV *)SvRV (coro_current);

2107

2337

struct coro *coro = SvSTATE_hv ((SV *)hv);

2108

2338

2109

if (expect_true (coro->saved_deffh))

2339

if (ecb_expect_true (coro->saved_deffh))

2110

2340

{

2111

2341

/* subsequent iteration */

2112

2342

SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;

2115

2345

if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)

2116

2346

|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))

2117

2347

{

2118

coro->invoke_cb = SvREFCNT_inc_NN ((SV *)cv_coro_terminate);

2119

coro->invoke_av = newAV ();

2120

2121

frame->prepare = prepare_nop;

2348

slf_init_terminate_cancel_common (aTHX_ frame, hv);

2349

return;

2122

2350

}

2123

2351

else

2124

2352

{

2353

2581

frame->check = slf_check_nop;

2354

2582

}

2355

2583

2584

/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */

2585

static void

2586

slf_destroy (pTHX_ struct coro *coro)

2587

{

2588

/* this callback is reserved for slf functions needing to do cleanup */

2589

if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)

2590

coro->slf_frame.destroy (aTHX_ &coro->slf_frame);

2591

2592

/*

2593

* The on_destroy above most likely is from an SLF call.

2594

* Since by definition the SLF call will not finish when we destroy

2595

* the coro, we will have to force-finish it here, otherwise

2596

* cleanup functions cannot call SLF functions.

2597

*/

2598

coro->slf_frame.prepare = 0;

2599

}

2600

2356

2601

/*

2357

2602

* these not obviously related functions are all rolled into one

2358

2603

* function to increase chances that they all will call transfer with the same

2367

2612

/* set up the slf frame, unless it has already been set-up */

2368

2613

/* the latter happens when a new coro has been started */

2369

2614

/* or when a new cctx was attached to an existing coroutine */

2370

if (expect_true (!slf_frame.prepare))

2615

if (ecb_expect_true (!slf_frame.prepare))

2371

2616

{

2372

2617

/* first iteration */

2373

2618

dSP;

2418

2663

slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */

2419

2664

2420

2665

/* exception handling */

2421

if (expect_false (CORO_THROW))

2666

if (ecb_expect_false (CORO_THROW))

2422

2667

{

2423

2668

SV *exception = sv_2mortal (CORO_THROW);

2424

2669

2429

2674

2430

2675

/* return value handling - mostly like entersub */

2431

2676

/* make sure we put something on the stack in scalar context */

2432

if (GIMME_V == G_SCALAR)

2677

if (GIMME_V == G_SCALAR

2678

&& ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))

2433

2679

{

2434

2680

dSP;

2435

2681

SV **bot = PL_stack_base + checkmark;

2436

2682

2437

2683

if (sp == bot) /* too few, push undef */

2438

2684

bot [1] = &PL_sv_undef;

2439

else if (sp != bot + 1) /* too many, take last one */

2685

else /* too many, take last one */

2440

2686

bot [1] = *sp;

2441

2687

2442

2688

SP = bot + 1;

2553

2799

NV next, every;

2554

2800

} PerlIOCede;

2555

2801

2556

static IV

2802

static IV ecb_cold

2557

2803

PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)

2558

2804

{

2559

2805

PerlIOCede *self = PerlIOSelf (f, PerlIOCede);

2564

2810

return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);

2565

2811

}

2566

2812

2567

static SV *

2813

static SV * ecb_cold

2568

2814

PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)

2569

2815

{

2570

2816

PerlIOCede *self = PerlIOSelf (f, PerlIOCede);

2686

2932

}

2687

2933

2688

2934

static void

2689

coro_semaphore_on_destroy (pTHX_ struct coro *coro)

2935

coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)

2690

2936

{

2691

2937

/* call $sem->adjust (0) to possibly wake up some other waiters */

2692

coro_semaphore_adjust (aTHX_ (AV *)coro->slf_frame.data, 0);

2938

coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);

2693

2939

}

2694

2940

2695

2941

static int

2697

2943

{

2698

2944

AV *av = (AV *)frame->data;

2699

2945

SV *count_sv = AvARRAY (av)[0];

2946

SV *coro_hv = SvRV (coro_current);

2700

2947

2701

2948

/* if we are about to throw, don't actually acquire the lock, just throw */

2702

2949

if (CORO_THROW)

2703

2950

return 0;

2704

2951

else if (SvIVX (count_sv) > 0)

2705

2952

{

2706

SvSTATE_current->on_destroy = 0;

2953

frame->destroy = 0;

2707

2954

2708

2955

if (acquire)

2709

2956

SvIVX (count_sv) = SvIVX (count_sv) - 1;

2718

2965

/* if we were woken up but can't down, we look through the whole */

2719

2966

/* waiters list and only add us if we aren't in there already */

2720

2967

/* this avoids some degenerate memory usage cases */

2721

2722

for (i = 1; i <= AvFILLp (av); ++i)

2723

if (AvARRAY (av)[i] == SvRV (coro_current))

2968

for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */

2969

if (AvARRAY (av)[i] == coro_hv)

2724

2970

return 1;

2725

2971

2726

av_push (av, SvREFCNT_inc (SvRV (coro_current)));

2972

av_push (av, SvREFCNT_inc (coro_hv));

2727

2973

return 1;

2728

2974

}

2729

2975

}

2756

3002

2757

3003

frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));

2758

3004

frame->prepare = prepare_schedule;

2759

2760

3005

/* to avoid race conditions when a woken-up coro gets terminated */

2761

3006

/* we arrange for a temporary on_destroy that calls adjust (0) */

2762

SvSTATE_current->on_destroy = coro_semaphore_on_destroy;

3007

frame->destroy = coro_semaphore_destroy;

2763

3008

}

2764

3009

}

2765

3010

2987

3232

static SV *prio_cv;

2988

3233

static SV *prio_sv;

2989

3234

2990

if (expect_false (!prio_cv))

3235

if (ecb_expect_false (!prio_cv))

2991

3236

{

2992

3237

prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);

2993

3238

prio_sv = newSViv (0);

3103

3348

return coro_sv;

3104

3349

}

3105

3350

3351

#ifndef __cplusplus

3352

ecb_cold XS(boot_Coro__State);

3353

#endif

3354

3355

#if CORO_JIT

3356

3357

static void ecb_noinline ecb_cold

3358

pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)

3359

{

3360

dSP;

3361

AV *av = newAV ();

3362

3363

av_store (av, 3, newSVuv (d));

3364

av_store (av, 2, newSVuv (c));

3365

av_store (av, 1, newSVuv (b));

3366

av_store (av, 0, newSVuv (a));

3367

3368

XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));

3369

3370

PUTBACK;

3371

}

3372

3373

static void ecb_noinline ecb_cold

3374

jit_init (pTHX)

3375

{

3376

dSP;

3377

SV *load, *save;

3378

char *map_base;

3379

char *load_ptr, *save_ptr;

3380

STRLEN load_len, save_len, map_len;

3381

int count;

3382

3383

eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);

3384

3385

PUSHMARK (SP);

3386

#define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));

3387

# include "state.h"

3388

#undef VARx

3389

count = call_pv ("Coro::State::_jit", G_ARRAY);

3390

SPAGAIN;

3391

3392

save = POPs; save_ptr = SvPVbyte (save, save_len);

3393

load = POPs; load_ptr = SvPVbyte (load, load_len);

3394

3395

map_len = load_len + save_len + 16;

3396

3397

map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);

3398

3399

assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));

3400

3401

load_perl_slots = (load_save_perl_slots_type)map_base;

3402

memcpy (map_base, load_ptr, load_len);

3403

3404

map_base += (load_len + 15) & ~15;

3405

3406

save_perl_slots = (load_save_perl_slots_type)map_base;

3407

memcpy (map_base, save_ptr, save_len);

3408

3409

/* we are good citizens and try to make the page read-only, so the evil evil */

3410

/* hackers might have it a bit more difficult */

3411

mprotect (map_base, map_len, PROT_READ | PROT_EXEC);

3412

3413

PUTBACK;

3414

eval_pv ("undef &Coro::State::_jit", 1);

3415

}

3416

3417

#endif

3418

3106

3419

MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_

3107

3420

3108

3421

PROTOTYPES: DISABLE

3116

3429

#endif

3117

3430

BOOT_PAGESIZE;

3118

3431

3432

/* perl defines these to check for existance first, but why it doesn't */

3433

/* just create them one at init time is not clear to me, except for */

3434

/* programs trying to delete them, but... */

3435

/* anyway, we declare this as invalid and make sure they are initialised here */

3436

DEFSV;

3437

ERRSV;

3438

3119

3439

cctx_current = cctx_new_empty ();

3120

3440

3121

3441

irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);

3167

3487

time_init (aTHX);

3168

3488

3169

3489

assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));

3490

#if CORO_JIT

3491

PUTBACK;

3492

jit_init (aTHX);

3493

SPAGAIN;

3494

#endif

3170

3495

}

3171

3496

3172

3497

SV *

3184

3509

CODE:

3185

3510

CORO_EXECUTE_SLF_XS (slf_init_transfer);

3186

3511

3187

bool

3188

_destroy (SV *coro_sv)

3189

CODE:

3190

RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));

3191

OUTPUT:

3192

RETVAL

3193

3194

3512

void

3195

3513

_exit (int code)

3196

3514

PROTOTYPE: $

3275

3593

if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))

3276

3594

{

3277

3595

struct coro *current = SvSTATE_current;

3596

struct CoroSLF slf_save;

3278

3597

3279

3598

if (current != coro)

3280

3599

{

3281

3600

PUTBACK;

3282

3601

save_perl (aTHX_ current);

3283

3602

load_perl (aTHX_ coro);

3603

/* the coro is most likely in an active SLF call.

3604

* while not strictly required (the code we execute is

3605

* not allowed to call any SLF functions), it's cleaner

3606

* to reinitialise the slf_frame and restore it later.

3607

* This might one day allow us to actually do SLF calls

3608

* from code executed here.

3609

*/

3610

slf_save = slf_frame;

3611

slf_frame.prepare = 0;

3284

3612

SPAGAIN;

3285

3613

}

3286

3614

3300

3628

if (current != coro)

3301

3629

{

3302

3630

PUTBACK;

3631

slf_frame = slf_save;

3303

3632

save_perl (aTHX_ coro);

3304

3633

load_perl (aTHX_ current);

3305

3634

SPAGAIN;

3314

3643

is_ready = CF_READY

3315

3644

is_running = CF_RUNNING

3316

3645

is_new = CF_NEW

3317

is_destroyed = CF_DESTROYED

3646

is_destroyed = CF_ZOMBIE

3647

is_zombie = CF_ZOMBIE

3318

3648

is_suspended = CF_SUSPENDED

3319

3649

CODE:

3320

3650

RETVAL = boolSV (coro->flags & ix);

3395

3725

cancel (Coro::State self)

3396

3726

CODE:

3397

3727

coro_state_destroy (aTHX_ self);

3398

coro_call_on_destroy (aTHX_ self); /* actually only for Coro objects */

3399

3400

3728

3401

3729

SV *

3402

3730

enable_times (int enabled = enable_times)

3421

3749

{

3422

3750

struct coro *current = SvSTATE (coro_current);

3423

3751

3424

if (expect_false (current == self))

3752

if (ecb_expect_false (current == self))

3425

3753

{

3426

3754

coro_times_update ();

3427

3755

coro_times_add (SvSTATE (coro_current));

3431

3759

PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));

3432

3760

PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));

3433

3761

3434

if (expect_false (current == self))

3762

if (ecb_expect_false (current == self))

3435

3763

coro_times_sub (SvSTATE (coro_current));

3436

3764

}

3437

3765

3462

3790

sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);

3463

3791

sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);

3464

3792

cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);

3465

cv_coro_terminate = get_cv ( "Coro::terminate" , GV_ADD);

3466

3793

coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);

3467

3794

av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);

3468

3795

av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);

3511

3838

RETVAL

3512

3839

3513

3840

void

3841

_destroy (Coro::State coro)

3842

CODE:

3843

/* used by the manager thread */

3844

coro_state_destroy (aTHX_ coro);

3845

3846

void

3847

on_destroy (Coro::State coro, SV *cb)

3848

CODE:

3849

coro_push_on_destroy (aTHX_ coro, newSVsv (cb));

3850

3851

void

3852

join (...)

3853

CODE:

3854

CORO_EXECUTE_SLF_XS (slf_init_join);

3855

3856

void

3514

3857

terminate (...)

3515

3858

CODE:

3516

3859

CORO_EXECUTE_SLF_XS (slf_init_terminate);

3517

3860

3518

3861

void

3862

cancel (...)

3863

CODE:

3864

CORO_EXECUTE_SLF_XS (slf_init_cancel);

3865

3866

int

3867

safe_cancel (Coro::State self, ...)

3868

C_ARGS: aTHX_ self, &ST (1), items - 1

3869

3870

void

3519

3871

schedule (...)

3520

3872

CODE:

3521

3873

CORO_EXECUTE_SLF_XS (slf_init_schedule);

3799

4151

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

3800

4152

3801

4153

void

3802

_may_delete (SV *sem, int count, int extra_refs)

4154

_may_delete (SV *sem, int count, unsigned int extra_refs)

3803

4155

PPCODE:

3804

4156

{

3805

4157

AV *av = (AV *)SvRV (sem);