diff options
| -rw-r--r-- | embed.fnc | 16 | ||||
| -rw-r--r-- | embed.h | 16 | ||||
| -rw-r--r-- | makedef.pl | 2 | ||||
| -rw-r--r-- | op.c | 243 | ||||
| -rw-r--r-- | op.h | 69 | ||||
| -rw-r--r-- | pad.c | 43 | ||||
| -rw-r--r-- | perl.h | 5 | ||||
| -rw-r--r-- | pp_ctl.c | 6 | ||||
| -rw-r--r-- | proto.h | 60 | ||||
| -rw-r--r-- | sv.c | 2 |
10 files changed, 412 insertions, 50 deletions
@@ -281,6 +281,9 @@ ApdR |SV* |cv_const_sv |NULLOK const CV *const cv : Used in pad.c pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv Apd |void |cv_undef |NN CV* cv +#ifndef PL_OP_SLAB_ALLOC +p |void |cv_forget_slab |NN CV *cv +#endif Ap |void |cx_dump |NN PERL_CONTEXT* cx Ap |SV* |filter_add |NULLOK filter_t funcp|NULLOK SV* datasv Ap |void |filter_del |NN filter_t funcp @@ -964,6 +967,11 @@ p |PerlIO*|nextargv |NN GV* gv AnpP |char* |ninstr |NN const char* big|NN const char* bigend \ |NN const char* little|NN const char* lend Ap |void |op_free |NULLOK OP* arg +#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE) +p |void |opslab_free |NN OPSLAB *slab +p |void |opslab_free_nopad|NN OPSLAB *slab +p |void |opslab_force_free|NN OPSLAB *slab +#endif : Used in perly.y #ifdef PERL_MAD p |OP* |package |NN OP* o @@ -1773,10 +1781,9 @@ s |OP* |ref_array_or_hash|NULLOK OP* cond s |void |process_special_blocks |NN const char *const fullname\ |NN GV *const gv|NN CV *const cv #endif -#if defined(PL_OP_SLAB_ALLOC) -Apa |void* |Slab_Alloc |size_t sz -Ap |void |Slab_Free |NN void *op -# if defined(PERL_DEBUG_READONLY_OPS) +Xpa |void* |Slab_Alloc |size_t sz +Xp |void |Slab_Free |NN void *op +#if defined(PERL_DEBUG_READONLY_OPS) : Used in perl.c poxM |void |pending_Slabs_to_ro : Used in OpREFCNT_inc() in sv.c @@ -1786,7 +1793,6 @@ poxM |PADOFFSET |op_refcnt_dec |NN OP *o # if defined(PERL_IN_OP_C) s |void |Slab_to_rw |NN void *op # endif -# endif #endif #if defined(PERL_IN_PERL_C) @@ -794,10 +794,6 @@ #define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c) #define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e) #endif -#if defined(PL_OP_SLAB_ALLOC) -#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a) -#define Slab_Free(a) Perl_Slab_Free(aTHX_ a) -#endif #if defined(UNLINK_ALL_VERSIONS) #define unlnk(a) Perl_unlnk(aTHX_ a) #endif @@ -994,6 +990,8 @@ # endif #endif #ifdef PERL_CORE +#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a) +#define Slab_Free(a) Perl_Slab_Free(aTHX_ a) #define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c) #define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) @@ -1269,6 +1267,14 @@ #define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c) # endif # endif +# if !defined(PL_OP_SLAB_ALLOC) +#define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a) +# endif +# if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE) +#define opslab_force_free(a) Perl_opslab_force_free(aTHX_ a) +#define opslab_free(a) Perl_opslab_free(aTHX_ a) +#define opslab_free_nopad(a) Perl_opslab_free_nopad(aTHX_ a) +# endif # if !defined(WIN32) #define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c) # endif @@ -1311,9 +1317,7 @@ # endif # if defined(PERL_DEBUG_READONLY_OPS) # if defined(PERL_IN_OP_C) -# if defined(PL_OP_SLAB_ALLOC) #define Slab_to_rw(a) S_Slab_to_rw(aTHX_ a) -# endif # endif # endif # if defined(PERL_IN_AV_C) diff --git a/makedef.pl b/makedef.pl index 95b4d660ad..ff26b741cd 100644 --- a/makedef.pl +++ b/makedef.pl @@ -413,8 +413,6 @@ unless ($define{'PL_OP_SLAB_ALLOC'}) { PL_OpPtr PL_OpSlab PL_OpSpace - Perl_Slab_Alloc - Perl_Slab_Free ); } @@ -298,6 +298,203 @@ Perl_Slab_Free(pTHX_ void *op) } } } +#else /* !defined(PL_OP_SLAB_ALLOC) */ + +/* See the explanatory comments above struct opslab in op.h. */ + +# ifndef PERL_SLAB_SIZE +# define PERL_SLAB_SIZE 64 +# endif + +/* rounds up to nearest pointer */ +# define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *)) +# define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o))) + +static OPSLAB * +S_new_slab(pTHX_ size_t sz) +{ + OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); + slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1); + return slab; +} + +void * +Perl_Slab_Alloc(pTHX_ size_t sz) +{ + dVAR; + OPSLAB *slab; + OPSLAB *slab2; + OPSLOT *slot; + OP *o; + size_t space; + + if (!PL_compcv || CvROOT(PL_compcv) + || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) + return PerlMemShared_calloc(1, sz); + + if (!CvSTART(PL_compcv)) { /* sneak it in here */ + CvSTART(PL_compcv) = + (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + } + else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; + + sz = SIZE_TO_PSIZE(sz) + OPSLOT_HEADER_P; + + if (slab->opslab_freed) { + OP **too = &slab->opslab_freed; + o = *too; + while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { + o = *(too = &o->op_next); + } + if (o) { + *too = o->op_next; + Zero(o, DIFF(o, OpSLOT(o)->opslot_next), I32 *); + o->op_slabbed = 1; + return (void *)o; + } + } + +# define INIT_OPSLOT \ + slot->opslot_slab = slab; \ + slot->opslot_next = slab2->opslab_first; \ + slab2->opslab_first = slot; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 + + /* The partially-filled slab is next in the chain. */ + slab2 = slab->opslab_next ? slab->opslab_next : slab; + if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { + /* Remaining space is too small. */ + + OPSLAB *newslab; + + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { + slot = &slab2->opslab_slots; + INIT_OPSLOT; + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + } + + /* Create a new slab. Make this one twice as big. */ + slot = slab2->opslab_first; + while (slot->opslot_next) slot = slot->opslot_next; + newslab = S_new_slab(aTHX_ DIFF(slab2, slot)*2); + newslab->opslab_next = slab->opslab_next; + slab->opslab_next = slab2 = newslab; + } + assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); + + /* Create a new op slot */ + slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz); + assert(slot >= &slab2->opslab_slots); + INIT_OPSLOT; + return (void *)o; +} + +# undef INIT_OPSLOT + +/* This cannot possibly be right, but it was copied from the old slab + allocator, to which it was originally added, without explanation, in + commit 083fcd5. */ +# ifdef NETWARE +# define PerlMemShared PerlMem +# endif + +void +Perl_Slab_Free(pTHX_ void *op) +{ + OP * const o = (OP *)op; + OPSLAB *slab; + + PERL_ARGS_ASSERT_SLAB_FREE; + + if (!o->op_slabbed) { + PerlMemShared_free(op); + return; + } + + slab = OpSLAB(o); + /* If this op is already freed, our refcount will get screwy. */ + assert(o->op_type != OP_FREED); + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + OpslabREFCNT_dec_padok(slab); +} + +void +Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) +{ + dVAR; + const bool havepad = !!PL_comppad; + PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; + if (havepad) { + ENTER; + PAD_SAVE_SETNULLPAD(); + } + opslab_free(slab); + if (havepad) LEAVE; +} + +void +Perl_opslab_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + PERL_ARGS_ASSERT_OPSLAB_FREE; + assert(slab->opslab_refcnt == 1); + for (; slab; slab = slab2) { + slab2 = slab->opslab_next; +# ifdef DEBUGGING + slab->opslab_refcnt = ~(size_t)0; +# endif + PerlMemShared_free(slab); + } +} + +void +Perl_opslab_force_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + OPSLOT *slot; +# ifdef DEBUGGING + size_t savestack_count = 0; +# endif + PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; + slab2 = slab; + do { + for (slot = slab2->opslab_first; + slot->opslot_next; + slot = slot->opslot_next) { + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree +# ifdef DEBUGGING + && ++savestack_count +# endif + ) + ) { + assert(slot->opslot_op.op_slabbed); + slab->opslab_refcnt++; /* op_free may free slab */ + op_free(&slot->opslot_op); + if (!--slab->opslab_refcnt) goto free; + } + } + } while ((slab2 = slab2->opslab_next)); + /* > 1 because the CV still holds a reference count. */ + if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ +# ifdef DEBUGGING + assert(savestack_count == slab->opslab_refcnt-1); +# endif + return; + } + free: + opslab_free(slab); +} + #endif /* * In the following definition, the ", (OP*)0" is just to make the compiler @@ -530,7 +727,14 @@ Perl_op_free(pTHX_ OP *o) dVAR; OPCODE type; - if (!o) +#ifndef PL_OP_SLAB_ALLOC + /* Though ops may be freed twice, freeing the op after its slab is a + big no-no. */ + assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); +#endif + /* During the forced freeing of ops after compilation failure, kidops + may be freed before their parents. */ + if (!o || o->op_type == OP_FREED) return; if (o->op_latefreed) { if (o->op_latefree) @@ -2850,6 +3054,9 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(PL_compcv); +#endif PL_compcv = 0; /* Register with debugger */ @@ -4369,6 +4576,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) * confident that nothing used that CV's pad while the * regex was parsed */ assert(AvFILLp(PL_comppad) == 0); /* just @_ */ +#ifndef PL_OP_SLAB_ALLOC + /* But we know that one op is using this CV's slab. */ + cv_forget_slab(PL_compcv); +#endif LEAVE_SCOPE(floor); pm->op_pmflags &= ~PMf_HAS_CV; } @@ -4412,6 +4623,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) * pad_fixup_inner_anons() can find it */ (void)pad_add_anon(cv, o->op_type); SvREFCNT_inc_simple_void(cv); + +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); +#endif } else { pm->op_code_list = expr; @@ -6217,7 +6432,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ loop->op_private = (U8)iterpflags; -#ifdef PL_OP_SLAB_ALLOC +#ifndef PL_OP_SLAB_ALLOC + if (DIFF(loop, OpSLOT(loop)->opslot_next) + < SIZE_TO_PSIZE(sizeof(LOOP))) +#endif { LOOP *tmp; NewOp(1234,tmp,1,LOOP); @@ -6225,9 +6443,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } -#else - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); -#endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); if (madsv) @@ -6878,6 +7093,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); +#endif sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; @@ -6908,6 +7126,8 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; AV *const temp_av = CvPADLIST(cv); CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t slabbed = CvSLABBED(cv); + OP * const cvstart = CvSTART(cv); assert(!CvWEAKOUTSIDE(cv)); assert(!CvCVGV_RC(cv)); @@ -6920,6 +7140,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvPADLIST(cv) = CvPADLIST(PL_compcv); CvOUTSIDE(PL_compcv) = temp_cv; CvPADLIST(PL_compcv) = temp_av; + CvSTART(cv) = CvSTART(PL_compcv); + CvSTART(PL_compcv) = cvstart; + if (slabbed) CvSLABBED_on(PL_compcv); + else CvSLABBED_off(PL_compcv); if (CvFILE(cv) && CvDYNFILE(cv)) { Safefree(CvFILE(cv)); @@ -6995,6 +7219,12 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvROOT(cv)->op_private |= OPpREFCOUNTED; OpREFCNT_set(CvROOT(cv), 1); +#ifndef PL_OP_SLAB_ALLOC + /* The cv no longer needs to hold a refcount on the slab, as CvROOT + itself has a refcount. */ + CvSLABBED_off(cv); + OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); +#endif CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); @@ -7376,6 +7606,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); +#endif #ifdef PERL_MAD op_getmad(o,pegop,'n'); op_getmad_weak(block, pegop, 'b'); @@ -28,9 +28,10 @@ * the op may be safely op_free()d multiple times * op_latefreed an op_latefree op has been op_free()d * op_attached this op (sub)tree has been attached to a CV + * op_slabbed allocated via opslab * op_savefree on savestack via SAVEFREEOP * - * op_spare two spare bits! + * op_spare a spare bit! * op_flags Flags common to all operations. See OPf_* below. * op_private Flags peculiar to a particular operation (BUT, * by default, set to the number of children until @@ -63,8 +64,9 @@ typedef PERL_BITFIELD16 Optype; PERL_BITFIELD16 op_latefree:1; \ PERL_BITFIELD16 op_latefreed:1; \ PERL_BITFIELD16 op_attached:1; \ + PERL_BITFIELD16 op_slabbed:1; \ PERL_BITFIELD16 op_savefree:1; \ - PERL_BITFIELD16 op_spare:2; \ + PERL_BITFIELD16 op_spare:1; \ U8 op_flags; \ U8 op_private; #endif @@ -710,19 +712,66 @@ least an C<UNOP>. #include "reentr.h" #endif -#if defined(PL_OP_SLAB_ALLOC) #define NewOp(m,var,c,type) \ (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type))) #define NewOpSz(m,var,size) \ (var = (OP *) Perl_Slab_Alloc(aTHX_ size)) #define FreeOp(p) Perl_Slab_Free(aTHX_ p) -#else -#define NewOp(m, var, c, type) \ - (var = (MEM_WRAP_CHECK_(c,type) \ - (type*)PerlMemShared_calloc(c, sizeof(type)))) -#define NewOpSz(m, var, size) \ - (var = (OP*)PerlMemShared_calloc(1, size)) -#define FreeOp(p) PerlMemShared_free(p) + +/* + * The per-CV op slabs consist of a header (the opslab struct) and a bunch + * of space for allocating op slots, each of which consists of two pointers + * followed by an op. The first pointer points to the next op slot. The + * second points to the slab. At the end of the slab is a null pointer, + * so that slot->opslot_next - slot can be used to determine the size + * of the op. + * + * Each CV can have multiple slabs; opslab_next points to the next slab, to + * form a chain. All bookkeeping is done on the first slab, which is where + * all the op slots point. + * + * Freed ops are marked as freed and attached to the freed chain + * via op_next pointers. + * + * When there is more than one slab, the second slab in the slab chain is + * assumed to be the one with free space available. It is used when allo- + * cating an op if there are no freed ops available or big enough. + */ + +#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE) +struct opslot { + /* keep opslot_next first */ + OPSLOT * opslot_next; /* next slot */ + OPSLAB * opslot_slab; /* owner */ + OP opslot_op; /* the op itself */ +}; + +struct opslab { + OPSLOT * opslab_first; /* first op in this slab */ + OPSLAB * opslab_next; /* next slab */ + OP * opslab_freed; /* chain of freed ops */ + size_t opslab_refcnt; /* number of ops */ + OPSLOT opslab_slots; /* slots begin here */ +}; + +# define OPSLOT_HEADER STRUCT_OFFSET(OPSLOT, opslot_op) +# define OPSLOT_HEADER_P (OPSLOT_HEADER/sizeof(I32 *)) +# ifdef DEBUGGING +# define OpSLOT(o) (assert(o->op_slabbed), \ + (OPSLOT *)(((char *)o)-OPSLOT_HEADER)) +# else +# define OpSLOT(o) ((OPSLOT *)(((char *)o)-OPSLOT_HEADER)) +# endif +# define OpSLAB(o) OpSLOT(o)->opslot_slab +# define OpslabREFCNT_dec(slab) \ + (((slab)->opslab_refcnt == 1) \ + ? opslab_free_nopad(slab) \ + : (void)--(slab)->opslab_refcnt) + /* Variant that does not null out the pads */ +# define OpslabREFCNT_dec_padok(slab) \ + (((slab)->opslab_refcnt == 1) \ + ? opslab_free(slab) \ + : (void)--(slab)->opslab_refcnt) #endif struct block_hooks { @@ -333,6 +333,7 @@ Perl_cv_undef(pTHX_ CV *cv) { dVAR; const PADLIST *padlist = CvPADLIST(cv); + bool const slabbed = !!CvSLABBED(cv); PERL_ARGS_ASSERT_CV_UNDEF; @@ -346,6 +347,7 @@ Perl_cv_undef(pTHX_ CV *cv) } CvFILE(cv) = NULL; + CvSLABBED_off(cv); if (!CvISXSUB(cv) && CvROOT(cv)) { if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); @@ -353,11 +355,29 @@ Perl_cv_undef(pTHX_ CV *cv) PAD_SAVE_SETNULLPAD(); +#ifndef PL_OP_SLAB_ALLOC + if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv))); +#endif op_free(CvROOT(cv)); CvROOT(cv) = NULL; CvSTART(cv) = NULL; LEAVE; } +#ifndef PL_OP_SLAB_ALLOC + else if (slabbed && CvSTART(cv)) { + ENTER; + PAD_SAVE_SETNULLPAD(); + + /* discard any leaked ops */ + opslab_force_free((OPSLAB *)CvSTART(cv)); + CvSTART(cv) = NULL; + + LEAVE; + } +# ifdef DEBUGGING + else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv); +# endif +#endif SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ CvGV_set(cv, NULL); @@ -470,6 +490,26 @@ Perl_cv_undef(pTHX_ CV *cv) CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON); } +#ifndef PL_OP_SLAB_ALLOC +void +Perl_cv_forget_slab(pTHX_ CV *cv) +{ + const bool slabbed = !!CvSLABBED(cv); + + PERL_ARGS_ASSERT_CV_FORGET_SLAB; + + if (!slabbed) return; + + CvSLABBED_off(cv); + + if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv))); + else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv)); +# ifdef DEBUGGING + else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv); +# endif +} +#endif + /* =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash @@ -1905,7 +1945,8 @@ Perl_cv_clone(pTHX_ CV *proto) SAVESPTR(PL_compcv); cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto))); - CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC); + CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC + |CVf_SLABBED); CvCLONED_on(cv); CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto)) @@ -2418,6 +2418,11 @@ typedef struct padop PADOP; typedef struct pvop PVOP; typedef struct loop LOOP; +#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE) +typedef struct opslab OPSLAB; +typedef struct opslot OPSLOT; +#endif + typedef struct block_hooks BHK; typedef struct custom_op XOP; @@ -3444,6 +3444,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PL_op = saveop; if (yystatus != 3) { if (PL_eval_root) { +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(evalcv); +#endif op_free(PL_eval_root); PL_eval_root = NULL; } @@ -3486,6 +3489,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) CopLINE_set(&PL_compiling, 0); SAVEFREEOP(PL_eval_root); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(evalcv); +#endif DEBUG_x(dump_eval()); @@ -23,6 +23,15 @@ PERL_CALLCONV int Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing) assert(stash) PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode); +PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz) + __attribute__malloc__ + __attribute__warn_unused_result__; + +PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SLAB_FREE \ + assert(op) + PERL_CALLCONV bool Perl__is_utf8__perl_idstart(pTHX_ const U8 *p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -4977,6 +4986,30 @@ STATIC I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) # endif #endif +#if !defined(PL_OP_SLAB_ALLOC) +PERL_CALLCONV void Perl_cv_forget_slab(pTHX_ CV *cv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CV_FORGET_SLAB \ + assert(cv) + +#endif +#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE) +PERL_CALLCONV void Perl_opslab_force_free(pTHX_ OPSLAB *slab) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE \ + assert(slab) + +PERL_CALLCONV void Perl_opslab_free(pTHX_ OPSLAB *slab) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OPSLAB_FREE \ + assert(slab) + +PERL_CALLCONV void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD \ + assert(slab) + +#endif #if !defined(SETUID_SCRIPTS_ARE_SECURE_NOW) # if defined(PERL_IN_PERL_C) STATIC void S_validate_suid(pTHX_ PerlIO *rsfp) @@ -5248,16 +5281,6 @@ STATIC void S_strip_return(pTHX_ SV *sv) # endif #endif #if defined(PERL_DEBUG_READONLY_OPS) -# if defined(PERL_IN_OP_C) -# if defined(PL_OP_SLAB_ALLOC) -STATIC void S_Slab_to_rw(pTHX_ void *op) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_SLAB_TO_RW \ - assert(op) - -# endif -# endif -# if defined(PL_OP_SLAB_ALLOC) PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_REFCNT_DEC \ @@ -5265,6 +5288,12 @@ PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) PERL_CALLCONV OP * Perl_op_refcnt_inc(pTHX_ OP *o); PERL_CALLCONV void Perl_pending_Slabs_to_ro(pTHX); +# if defined(PERL_IN_OP_C) +STATIC void S_Slab_to_rw(pTHX_ void *op) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SLAB_TO_RW \ + assert(op) + # endif #endif #if defined(PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION) @@ -7469,17 +7498,6 @@ PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr) #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) STATIC void S_pidgone(pTHX_ Pid_t pid, int status); #endif -#if defined(PL_OP_SLAB_ALLOC) -PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz) - __attribute__malloc__ - __attribute__warn_unused_result__; - -PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_SLAB_FREE \ - assert(op) - -#endif #if defined(UNLINK_ALL_VERSIONS) PERL_CALLCONV I32 Perl_unlnk(pTHX_ const char* f) __attribute__nonnull__(pTHX_1); @@ -12205,10 +12205,12 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) OP_REFCNT_LOCK; CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); OP_REFCNT_UNLOCK; + CvSLABBED_off(dstr); } else if (CvCONST(dstr)) { CvXSUBANY(dstr).any_ptr = sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } + assert(!CvSLABBED(dstr)); if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ |