This addresses bugs #111462 and #112312 and part of #107000.
When a longjmp occurs during lexing, parsing or compilation, any ops
in C autos that are not referenced anywhere are leaked.
This commit introduces op slabs that are attached to the currently-
compiling CV. New ops are allocated on the slab. When an error
occurs and the CV is freed, any ops remaining are freed.
This is based on Nick Ing-Simmons’ old experimental op slab implemen-
tation, but it had to be rewritten to work this way.
The old slab allocator has a pointer before each op that points to a
reference count stored at the beginning of the slab. Freed ops are
never reused. When the last op on a slab is freed, the slab itself is
freed. When a slab fills up, a new one is created.
To allow iteration through the slab to free everything, I had to have
two pointers; one points to the next item (op slot); the other points
to the slab, for accessing the reference count. Ops come in different
sizes, so adding sizeof(OP) to a pointer won’t work.
The old slab allocator puts the ops at the end of the slab first, the
idea being that the leaves are allocated first, so the order will be
cache-friendly as a result. I have preserved that order for a dif-
ferent reason: We don’t need to store the size of the slab (slabs
vary in size; see below) if we can simply follow pointers to find
the last op.
I tried eliminating reference counts altogether, by having all ops
implicitly attached to PL_compcv when allocated and freed when the CV
is freed. That also allowed op_free to skip FreeOp altogether, free-
ing ops faster. But that doesn’t work in those cases where ops need
to survive beyond their CVs; e.g., re-evals.
The CV also has to have a reference count on the slab. Sometimes the
first op created is immediately freed. If the reference count of
the slab reaches 0, then it will be freed with the CV still point-
ing to it.
CVs use the new CVf_SLABBED flag to indicate that the CV has a refer-
ence count on the slab. When this flag is set, the slab is accessible
via CvSTART when CvROOT is not set, or by subtracting two pointers
(2*sizeof(I32 *)) from CvROOT when it is set. I decided to sneak the
slab into CvSTART during compilation, because enlarging the xpvcv
struct by another pointer would make all CVs larger, even though this
patch only benefits few (programs using string eval).
When the CVf_SLABBED flag is set, the CV takes responsibility for
freeing the slab. If CvROOT is not set when the CV is freed or
undeffed, it is assumed that a compilation error has occurred, so the
op slab is traversed and all the ops are freed.
Under normal circumstances, the CV forgets about its slab (decrement-
ing the reference count) when the root is attached. So the slab ref-
erence counting that happens when ops are freed takes care of free-
ing the slab. In some cases, the CV is told to forget about the slab
(cv_forget_slab) precisely so that the ops can survive after the CV is
done away with.
Forgetting the slab when the root is attached is not strictly neces-
sary, but avoids potential problems with CvROOT being written over.
There is code all over the place, both in core and on CPAN, that does
things with CvROOT, so forgetting the slab makes things more robust
and avoids potential problems.
Since the CV takes ownership of its slab when flagged, that flag is
never copied when a CV is cloned, as one CV could free a slab that
another CV still points to, since forced freeing of ops ignores the
reference count (but asserts that it looks right).
To avoid slab fragmentation, freed ops are marked as freed and
attached to the slab’s freed chain (an idea stolen from DBM::Deep).
Those freed ops are reused when possible. I did consider not reusing
freed ops, but realised that would result in significantly higher mem-
ory using for programs with large ‘if (DEBUG) {...}’ blocks.
SAVEFREEOP was slightly problematic. Sometimes it can cause an op to
be freed after its CV. If the CV has forcibly freed the ops on its
slab and the slab itself, then we will be fiddling with a freed slab.
Making SAVEFREEOP a no-op won’t help, as sometimes an op can be
savefreed when there is no compilation error, so the op would never
be freed. It holds a reference count on the slab, so the whole
slab would leak. So SAVEFREEOP now sets a special flag on the op
(->op_savefree). The forced freeing of ops after a compilation error
won’t free any ops thus marked.
Since many pieces of code create tiny subroutines consisting of only
a few ops, and since a huge slab would be quite a bit of baggage for
those to carry around, the first slab is always very small. To avoid
allocating too many slabs for a single CV, each subsequent slab is
twice the size of the previous.
Smartmatch expects to be able to allocate an op at run time, run it,
and then throw it away. For that to work the op is simply mallocked
when PL_compcv has’t been set up. So all slab-allocated ops are
marked as such (->op_slabbed), to distinguish them from mallocked ops.
All of this is kept under lock and key via #ifdef PERL_CORE, as it
should be completely transparent. If it isn’t transparent, I would
consider that a bug.
I have left the old slab allocator (PL_OP_SLAB_ALLOC) in place, as
it is used by PERL_DEBUG_READONLY_OPS, which I am not about to
rewrite. :-)
Concerning the change from A to X for slab allocation functions:
Many times in the past, A has been used for functions that were
not intended to be public but were used for public macros. Since
PL_OP_SLAB_ALLOC is rarely used, it didn’t make sense for Perl_Slab_*
to be API functions, since they were rarely actually available. To
avoid propagating this mistake further, they are now X.
: 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
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
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
# if defined(PERL_IN_OP_C)
s |void |Slab_to_rw |NN void *op
# endif
-# endif
#endif
#if defined(PERL_IN_PERL_C)
#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
# 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)
#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
# 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)
PL_OpPtr
PL_OpSlab
PL_OpSpace
- Perl_Slab_Alloc
- Perl_Slab_Free
);
}
}
}
}
+#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
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)
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 */
* 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;
}
* 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;
/* 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);
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)
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;
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));
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));
: 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));
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');
* 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
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
#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 {
{
dVAR;
const PADLIST *padlist = CvPADLIST(cv);
+ bool const slabbed = !!CvSLABBED(cv);
PERL_ARGS_ASSERT_CV_UNDEF;
}
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");
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);
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
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))
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;
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;
}
CopLINE_set(&PL_compiling, 0);
SAVEFREEOP(PL_eval_root);
+#ifndef PL_OP_SLAB_ALLOC
+ cv_forget_slab(evalcv);
+#endif
DEBUG_x(dump_eval());
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);
# 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)
# 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 \
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)
#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);
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 */
https://perl5.git.perl.org / perl5.git / commitdiff