30 Jun 2012 07:34
[perl #112312] perl5 version 5.14.2 coredumps during perl -c
Father Chrysostomos via RT <perlbug-comment <at> perl.org>
2012-06-30 05:34:30 GMT
2012-06-30 05:34:30 GMT
On Mon Jun 25 14:50:38 2012, sprout wrote: > On Mon Jun 25 14:41:06 2012, davem wrote: > > That "we guessed we had a code block but it turns out we didn't" bit of > > code was always a bit of hack, and now that I realise it leaves an op > > allocated in the wrong CV, I like it even less. > > > > I'm tempted to eliminate it altogether. Would doing this enable you to > > simplify the slab code? > > No, because I still have to take SAVEFREEOP into account.I could > fiddle to get savestack items the right order, but what I have currently > is far more robust than the alternative. > > The three things I didn’t have working with my earlier (non-refcounted) > system were: > • smartmatch > • SAVEFREEOP - I just made it a no-op to get tests passing, which leaked > ops when there were no errors > • re-evals Attached is an early diff containing the alternative mentioned above, which I am attaching here for posterity. This was before the re-eval rewrite was merged, before newSTUB, and before I had thought of the CVf_SLABBED flag. The corresponding workarounds are a twisted maze. The only advantage was that freeing a slab was faster, but probably less robust, in that some ops might not be cleared and no check was done. -- Father Chrysostomos
diff --git a/cop.h b/cop.h
index af98965..650ada4 100644
--- a/cop.h
+++ b/cop.h
<at> <at> -719,6 +719,10 <at> <at> struct block_eval {
PL_eval_root = cx->blk_eval.old_eval_root; \
if (cx->blk_eval.old_namesv) \
sv_2mortal(cx->blk_eval.old_namesv); \
+ if (cx->blk_eval.cv) { \
+ assert(CvDEPTH(cx->blk_eval.cv) <= 1); \
+ CvDEPTH(cx->blk_eval.cv) = 0; \
+ } \
} STMT_END
/* loop context */
diff --git a/embed.fnc b/embed.fnc
index 594485d..238e89e 100644
--- a/embed.fnc
+++ b/embed.fnc
<at> <at> -962,6 +962,9 <at> <at> 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
+#ifndef PL_OP_SLAB_ALLOC
+p |void |op_free_root |NN OP* o
+#endif
: Used in perly.y
#ifdef PERL_MAD
p |OP* |package |NN OP* o
<at> <at> -1770,10 +1773,12 <at> <at> 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
+#ifndef PL_OP_SLAB_ALLOC
+p |void |Slab_Free_Slab |NN OPSLAB *slab|bool fast
+#endif
+#if defined(PERL_DEBUG_READONLY_OPS)
: Used in perl.c
poxM |void |pending_Slabs_to_ro
: Used in OpREFCNT_inc() in sv.c
<at> <at> -1783,7 +1788,6 <at> <at> 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)
diff --git a/embed.h b/embed.h
index a980a87..a2e4ece 100644
--- a/embed.h
+++ b/embed.h
<at> <at> -795,10 +795,6 <at> <at>
#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
<at> <at> -993,6 +989,8 <at> <at>
# 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)
<at> <at> -1265,6 +1263,10 <at> <at>
#define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c)
# endif
# endif
+# if !defined(PL_OP_SLAB_ALLOC)
+#define Slab_Free_Slab(a,b) Perl_Slab_Free_Slab(aTHX_ a,b)
+#define op_free_root(a) Perl_op_free_root(aTHX_ a)
+# endif
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
<at> <at> -1307,9 +1309,7 <at> <at>
# 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/op.c b/op.c
index 400291a..1cc3c59 100644
--- a/op.c
+++ b/op.c
<at> <at> -297,6 +297,182 <at> <at> 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
+
+# define SIZE_TO_POINTERS(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+# define DIFF(o,p) ((I32 **)(p) - (I32**)(o))
+# define NOT_FIRST_SLAB (OP *)((STRLEN *)0 + 1)
+
+static OPSLAB *
+new_slab(size_t sz)
+{
+ OPSLAB *slab = PerlMemShared_calloc(sz, sizeof(I32 *));
+ slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ slab->opslab_first->opslot_next = (OPSLOT *)slab;
+ return slab;
+}
+
+static OPSLAB *
+OpSLAB(OP *o)
+{
+if(!o->op_slabbed) Perl_warn_nocontext("op %p is not slabbed", o);
+ OPSLOT *slot = OpSLOT(o);
+ OPSLAB *slab;
+ while (slot->opslot_next > slot) slot = slot->opslot_next;
+ slab = (OPSLAB *)slot->opslot_next;
+ while (slab->opslab_freed == NOT_FIRST_SLAB) slab = slab->opslab_next;
+ return slab;
+}
+
+void *
+Perl_Slab_Alloc(pTHX_ size_t sz)
+{
+ dVAR;
+ OPSLAB *slab;
+ OPSLAB *slab2;
+ OPSLOT *slot;
+ OP *o;
+ size_t space;
+
+ assert(PL_compcv);
+ assert(!CvISXSUB(PL_compcv));
+DEBUG_U(if (CvROOT(PL_compcv)) { Perl_warn(aTHX_ "compcv %p root %p", PL_compcv,
CvROOT(PL_compcv)); Perl_sv_dump(aTHX_ (SV *)PL_compcv); });
+ assert(!CvROOT(PL_compcv));
+ if (!CvSTART(PL_compcv)) { /* sneak it in here */
+ CvSTART(PL_compcv) = (OP *)(slab = new_slab(PERL_SLAB_SIZE));
+ slab->opslab_next = slab;
+ }
+ else slab = (OPSLAB *)CvSTART(PL_compcv);
+
+/* slab->opslab_refcnt++;*/
+
+ /*
+ * Round up the op size to the nearest pointer, and add one more
+ * pointer for opslot_next; convert to a pointer count in the process.
+ */
+ sz = SIZE_TO_POINTERS(sz) + 1;
+
+ if (slab->opslab_freed) {
+ OP **too = &slab->opslab_freed;
+ o = *too;
+ DEBUG_U(Perl_warn(aTHX_ "found free op at %p, slab %p", o, slab));
+ while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz)
+{ DEBUG_U(Perl_warn(aTHX_ "Alas! too small"));
+ o = *(too = &o->op_next);
+ DEBUG_U(if(o) Perl_warn(aTHX_ "found another free op at %p", o));}
+ if (o) {
+ *too = o->op_next;
+ Zero(o, DIFF(OpSLOT(o), OpSLOT(o)->opslot_next)-1, I32 *);
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ return (void *)o;
+ }
+ }
+
+ slab2 = slab;
+ while (slab2->opslab_next != slab) slab2 = slab2->opslab_next;
+ 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_POINTERS(sizeof(OP))) { /* not >= */
+ slot = &slab2->opslab_slots;
+ slot->opslot_next = slab2->opslab_first;
+ slab2->opslab_first = slot;
+ o = &slot->opslot_op;
+ o->op_type = OP_FREED;
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ 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 > (OPSLOT *)slab2)
+ slot = slot->opslot_next;
+ newslab = new_slab(DIFF(slab2, slot)*2);
+ slab2->opslab_next = newslab;
+ newslab->opslab_next = slab;
+ newslab->opslab_freed = NOT_FIRST_SLAB;
+ 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);
+ slot->opslot_next = slab2->opslab_first;
+ slab2->opslab_first = slot;
+ o = &slot->opslot_op;
+ DEBUG_U(Perl_warn(aTHX_ "allocating op at %p, slab %p", o, slab));
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ return (void *)o;
+}
+
+void
+Perl_Slab_Free(pTHX_ void *op)
+{
+ OP * const o = (OP *)op;
+ OPSLAB * const slab = OpSLAB(o);
+ PERL_ARGS_ASSERT_SLAB_FREE;
+ assert(o->op_slabbed);
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+/* Perl_warn(aTHX_ "free op at %p, recorded in slab %p", o, slab);*/
+ slab->opslab_freed = o;
+/* if (!--slab-≥opslab_refcnt) Slab_Free_Slab(slab, 1);*/
+}
+
+/* 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
+
+/* If fast is true, it is a promise that all ops have been freed. */
+
+void
+Perl_Slab_Free_Slab(pTHX_ OPSLAB *slab, bool fast) {
+ OPSLAB *slab2 = slab;
+ OPSLOT *slot;
+ PERL_ARGS_ASSERT_SLAB_FREE_SLAB;
+ assert(slab->opslab_freed != NOT_FIRST_SLAB);
+ DEBUG_U(Perl_warn(aTHX_ "freeing slab %p", slab));
+ if (!fast) {
+ do {
+ for (slot = slab->opslab_first;
+ slot->opslot_next > (OPSLOT *)slab;
+ slot = slot->opslot_next) {
+ if (slot->opslot_op.op_type != OP_FREED)
+ op_free(&slot->opslot_op);
+ }
+ /* Don’t free the slab yet, as ops in other slabs might still
+ point to it. */
+ } while ((slab2 = slab2->opslab_next) != slab);
+ }
+ for (;;) {
+ OPSLAB *nextslab = slab2->opslab_next;
+ PerlMemShared_free(slab2);
+ if (nextslab == slab) break;
+ slab2 = nextslab;
+ }
+}
+
#endif
/*
* In the following definition, the ", (OP*)0" is just to make the compiler
<at> <at> -523,14 +699,13 <at> <at> S_op_destroy(pTHX_ OP *o)
/* Destructor */
-void
-Perl_op_free(pTHX_ OP *o)
+static void
+S_op_free(pTHX_ OP *o, bool fast, bool is_root)
{
dVAR;
OPCODE type;
- if (!o)
- return;
+ assert(o);
if (o->op_latefreed) {
if (o->op_latefree)
return;
<at> <at> -573,7 +748,7 <at> <at> Perl_op_free(pTHX_ OP *o)
register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
- op_free(kid);
+ S_op_free(aTHX_ kid, fast, 0);
}
}
<at> <at> -599,13 +774,34 <at> <at> Perl_op_free(pTHX_ OP *o)
return;
}
do_free:
- FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
PL_op = NULL;
#endif
+#ifndef PL_OP_SLAB_ALLOC
+ if (fast) {
+ if (is_root) Slab_Free_Slab(OpSLAB(o), 1);
+ return;
+ }
+#endif
+ FreeOp(o);
+}
+
+void
+Perl_op_free(pTHX_ OP *o)
+{
+ if (o) S_op_free(aTHX_ o, 0, 0);
}
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_op_free_root(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_OP_FREE_ROOT;
+ S_op_free(aTHX_ o, 1, 1);
+}
+#endif
+
void
Perl_op_clear(pTHX_ OP *o)
{
<at> <at> -2830,6 +3026,7 <at> <at> Perl_newPROG(pTHX_ OP *o)
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
+ CvROOT(PL_compcv) = PL_eval_root;
i = PL_savestack_ix;
SAVEFREEOP(o);
ENTER;
<at> <at> -2853,6 +3050,8 <at> <at> Perl_newPROG(pTHX_ OP *o)
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
finalize_optree(PL_main_root);
+ /* Stop CvSTART from pointing to the op slab. */
+ CvSTART(PL_compcv) = NULL;
PL_compcv = 0;
/* Register with debugger */
<at> <at> -4644,7 +4843,7 <at> <at> Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
OP *imop;
OP *veop;
#ifdef PERL_MAD
- OP *pegop = newOP(OP_NULL,0);
+ OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
#endif
SV *use_version = NULL;
<at> <at> -4779,11 +4978,6 <at> <at> Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
PL_cop_seqmax++;
#ifdef PERL_MAD
- if (!PL_madskills) {
- /* FIXME - don't allocate pegop if !PL_madskills */
- op_free(pegop);
- return NULL;
- }
return pegop;
#endif
}
<at> <at> -4840,10 +5034,23 <at> <at> Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
dVAR;
OP *veop, *imop;
- OP * const modname = newSVOP(OP_CONST, 0, name);
+ OP *modname;
+ I32 floor;
PERL_ARGS_ASSERT_VLOAD_MODULE;
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work. */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
+ floor = start_subparse(FALSE, 0);
+
+ modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
<at> <at> -4866,16 +5073,7 <at> <at> Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
}
}
- /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
- * that it has a PL_parser to play with while doing that, and also
- * that it doesn't mess with any existing parser, by creating a tmp
- * new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work. */
-
- ENTER;
- SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, LEX_START_SAME_FILTER);
- utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ utilize(!(flags & PERL_LOADMOD_DENY), floor,
veop, modname, imop);
LEAVE;
}
<at> <at> -6060,7 +6258,10 <at> <at> 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(OpSLOT(loop), OpSLOT(loop)->opslot_next)
+ < SIZE_TO_POINTERS(sizeof(LOOP))+1)
+#endif
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
<at> <at> -6068,9 +6269,6 <at> <at> 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)
<at> <at> -6699,6 +6897,9 <at> <at> 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
+ if (CvSTART(cv)) Slab_Free_Slab((OPSLAB *)CvSTART(cv), 0);
+#endif
sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
<at> <at> -6749,6 +6950,8 <at> <at> 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) = NULL;
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
<at> <at> -6837,15 +7040,26 <at> <at> Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
block = newblock;
}
else block->op_attached = 1;
- CvROOT(cv) = CvLVALUE(cv)
+ block = CvLVALUE(cv)
? newUNOP(OP_LEAVESUBLV, 0,
op_lvalue(scalarseq(block), OP_LEAVESUBLV))
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ block->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(block, 1);
+ o = LINKLIST(block);
+ block->op_next = 0;
+#ifdef PL_OP_SLAB_ALLOC
+ CvROOT(cv) = block;
+ CvSTART(cv) = o;
+#endif
+ CALL_PEEP(o);
+#ifndef PL_OP_SLAB_ALLOC
+ /* Do this after CALL_PEEP, as CALL_PEEP could create new ops, and
+ needs to see the slab in CvSTART(cv). And CvROOT(cv) must be null
+ for CvSTART(cv) to contain the slab. */
+ CvROOT(cv) = block;
+ CvSTART(cv) = o;
+#endif
finalize_optree(CvROOT(cv));
/* now that optimizer has done its work, adjust pad values */
diff --git a/op.h b/op.h
index 6aa16f5..edfb9bd 100644
--- a/op.h
+++ b/op.h
<at> <at> -28,8 +28,9 <at> <at>
* 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_spare three spare bits!
+ * op_spare two spare bits!
* 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
<at> <at> -62,7 +63,8 <at> <at> typedef PERL_BITFIELD16 Optype;
PERL_BITFIELD16 op_latefree:1; \
PERL_BITFIELD16 op_latefreed:1; \
PERL_BITFIELD16 op_attached:1; \
- PERL_BITFIELD16 op_spare:3; \
+ PERL_BITFIELD16 op_slabbed:1; \
+ PERL_BITFIELD16 op_spare:2; \
U8 op_flags; \
U8 op_private;
#endif
<at> <at> -579,6 +581,52 <at> <at> struct loop {
# define Nullop ((OP*)NULL)
#endif
+/*
+ * 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 a pointer
+ * followed by an op. Each pointer points to the next op slot. At the
+ * end of the slab is a pointer back to the beginning, so that
+ * slot->opslot_next - slot can be used to determine the size of the op,
+ * and so that the beginning of the slab can be found by following the
+ * opslot_next pointers.
+ *
+ * Each CV can have multiple slabs; opslab_next points to the next slab, to
+ * form a chain.
+ *
+ * Freed ops are marked as freed and attached to the freed chain
+ * via op_next pointers. Only the first slab uses opslab_freed and
+ * opslab_refcnt.
+ *
+ * The last slab in the slab chain is assumed to be the one with free space
+ * available. It is used when allocating an op if there are no freed ops
+ * available.
+ */
+
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+struct opslot {
+ OPSLOT * opslot_next; /* next slot */
+ 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 */
+};
+
+/* First struct member used only by first slab */
+# define OPSLAB_UNUSED opslot_freed
+
+# ifdef DEBUGGING
+# define OpSLOT(o) (assert(o->op_slabbed), \
+ (OPSLOT *)(((I32 **)o)-1))
+# else
+# define OpSLOT(o) ((OPSLOT *)(((I32 **)o)-1))
+# endif
+#endif
+
/* Lowest byte of PL_opargs */
#define OA_MARK 1
#define OA_FOLDCONST 2
<at> <at> -694,20 +742,11 <at> <at> 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)
-#endif
struct block_hooks {
U32 bhk_flags;
diff --git a/opnames.h b/opnames.h
index 8b6a39a..fd86d2a 100644
--- a/opnames.h
+++ b/opnames.h
<at> <at> -392,6 +392,7 <at> <at> typedef enum opcode {
} opcode;
#define MAXO 374
+#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
all the member OPs are contiguous in regen/opcodes table.
diff --git a/pad.c b/pad.c
index 689a180..a1f42b4 100644
--- a/pad.c
+++ b/pad.c
<at> <at> -346,17 +346,34 <at> <at> Perl_cv_undef(pTHX_ CV *cv)
}
CvFILE(cv) = NULL;
- if (!CvISXSUB(cv) && CvROOT(cv)) {
+ if (!CvISXSUB(cv)) {
+ if (CvROOT(cv)) {
if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
ENTER;
PAD_SAVE_SETNULLPAD();
+#ifdef PL_OP_SLAB_ALLOC
op_free(CvROOT(cv));
+#else
+ op_free_root(CvROOT(cv));
+#endif
CvROOT(cv) = NULL;
CvSTART(cv) = NULL;
LEAVE;
+ }
+#ifndef PL_OP_SLAB_ALLOC
+ else if (CvSTART(cv)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ Slab_Free_Slab((OPSLAB *)CvSTART(cv), 0);
+ CvSTART(cv) = NULL;
+
+ LEAVE;
+ }
+#endif
}
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV_set(cv, NULL);
diff --git a/perl.c b/perl.c
index 79d15e2..04b58f2 100644
--- a/perl.c
+++ b/perl.c
<at> <at> -747,7 +747,11 <at> <at> perl_destruct(pTHXx)
if (CvPADLIST(PL_main_cv)) {
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
}
+#ifdef PL_OP_SLAB_ALLOC
op_free(PL_main_root);
+#else
+ op_free_root(PL_main_root);
+#endif
PL_main_root = NULL;
}
PL_main_start = NULL;
<at> <at> -1616,7 +1620,11 <at> <at> perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
}
if (PL_main_root) {
+#ifdef PL_OP_SLAB_ALLOC
op_free(PL_main_root);
+#else
+ op_free_root(PL_main_root);
+#endif
PL_main_root = NULL;
}
PL_main_start = NULL;
diff --git a/perl.h b/perl.h
index 798e7b7..ffddee9 100644
--- a/perl.h
+++ b/perl.h
<at> <at> -2418,6 +2418,11 <at> <at> 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;
diff --git a/pp_ctl.c b/pp_ctl.c
index e196022..45afc70 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
<at> <at> -3673,7 +3673,8 <at> <at> S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
PL_op = saveop;
if (yystatus != 3) {
if (PL_eval_root) {
- op_free(PL_eval_root);
+assert(CvROOT(evalcv) == PL_eval_root);
+/* op_free(PL_eval_root);*/
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
<at> <at> -3724,10 +3725,12 <at> <at> S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
}
else if (!startop) LEAVE_with_name("evalcomp");
CopLINE_set(&PL_compiling, 0);
+ assert(CvROOT(evalcv) == PL_eval_root);
if (startop) {
*startop = PL_eval_root;
- } else
- SAVEFREEOP(PL_eval_root);
+ CvROOT(evalcv) = NULL;
+ CvSTART(evalcv) = NULL; /* XXX This leaks a slab. */
+ }
DEBUG_x(dump_eval());
<at> <at> -4389,11 +4392,6 <at> <at> PP(pp_leaveeval)
gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
-#ifdef DEBUGGING
- assert(CvDEPTH(evalcv) == 1);
-#endif
- CvDEPTH(evalcv) = 0;
-
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
{
diff --git a/proto.h b/proto.h
index 02bc3cc..c65e9cd 100644
--- a/proto.h
+++ b/proto.h
<at> <at> -23,6 +23,15 <at> <at> 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);
<at> <at> -4977,6 +4986,18 <at> <at> STATIC I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
# endif
#endif
+#if !defined(PL_OP_SLAB_ALLOC)
+PERL_CALLCONV void Perl_Slab_Free_Slab(pTHX_ OPSLAB *slab, bool fast)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_FREE_SLAB \
+ assert(slab)
+
+PERL_CALLCONV void Perl_op_free_root(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_FREE_ROOT \
+ assert(o)
+
+#endif
#if !defined(SETUID_SCRIPTS_ARE_SECURE_NOW)
# if defined(PERL_IN_PERL_C)
STATIC void S_validate_suid(pTHX_ PerlIO *rsfp)
<at> <at> -5248,16 +5269,6 <at> <at> 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 \
<at> <at> -5265,6 +5276,12 <at> <at> 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)
<at> <at> -7456,17 +7473,6 <at> <at> 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);
diff --git a/regen/opcode.pl b/regen/opcode.pl
index d8186cd..1c15edc 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
<at> <at> -46,6 +46,8 <at> <at> while (<OPS>) {
warn qq[Description "$desc" duplicates $seen{$desc}\n]
if $seen{$desc} and $key ne "transr";
die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key};
+ die qq[Opcode "freed" is reserved for the slab allocator\n]
+ if $key eq 'freed';
$seen{$desc} = qq[description of opcode "$key"];
$seen{$key} = qq[opcode "$key"];
<at> <at> -189,6 +191,7 <at> <at> for ( <at> ops) {
print $on "\t", tab(3,"OP_max"), "\n";
print $on "} opcode;\n";
print $on "\n#define MAXO ", scalar <at> ops, "\n";
+print $on "#define OP_FREED MAXO\n";
# Emit op names and descriptions.
diff --git a/scope.h b/scope.h
index 74ebed9..ec78b95 100644
--- a/scope.h
+++ b/scope.h
<at> <at> -177,7 +177,11 <at> <at> scope has the given name. Name must be a literal string.
#define SAVEPADSVANDMORTALIZE(s) save_padsv_and_mortalize(s)
#define SAVEFREESV(s) save_freesv(MUTABLE_SV(s))
#define SAVEMORTALIZESV(s) save_mortalizesv(MUTABLE_SV(s))
-#define SAVEFREEOP(o) save_freeop((OP*)(o))
+#ifdef PL_OP_SLAB_ALLOC
+# define SAVEFREEOP(o) save_freeop((OP*)(o))
+#else
+# define SAVEFREEOP(o) NOOP
+#endif
#define SAVEFREEPV(p) save_freepv((char*)(p))
#define SAVECLEARSV(sv) save_clearsv((SV**)&(sv))
#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
diff --git a/sv.c b/sv.c
index fcd76a9..549cad0 100644
--- a/sv.c
+++ b/sv.c
<at> <at> -9026,13 +9026,15 <at> <at> Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
*st = GvESTASH(gv);
if (lref & ~GV_ADDMG && !GvCVu(gv)) {
SV *tmpsv;
+ I32 floor;
ENTER;
tmpsv = newSV(0);
gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- newSUB(start_subparse(FALSE, 0),
+ floor = start_subparse(FALSE, 0);
+ newSUB(floor,
newSVOP(OP_CONST, 0, tmpsv),
NULL, NULL);
LEAVE;
RSS Feed