/* op.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* either way, as the saying is, if you follow me." --the Gaffer
*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-/* #define PL_OP_SLAB_ALLOC */
+#if defined(PL_OP_SLAB_ALLOC)
+
+#ifndef PERL_SLAB_SIZE
+#define PERL_SLAB_SIZE 2048
+#endif
-#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
-#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL; /* XXX threadead */
-static int PL_OpSpace = 0; /* XXX threadead */
-#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
- var = (type *)(PL_OpPtr -= c*sizeof(type)); \
- else \
- var = (type *) Slab_Alloc(m,c*sizeof(type)); \
- } while (0)
+#define NewOp(m,var,c,type) \
+ STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
+
+#define FreeOp(p) Slab_Free(p)
STATIC void *
S_Slab_Alloc(pTHX_ int m, size_t sz)
{
- Newz(m,PL_OpPtr,SLAB_SIZE,char);
- PL_OpSpace = SLAB_SIZE - sz;
- return PL_OpPtr += PL_OpSpace;
+ /*
+ * To make incrementing use count easy PL_OpSlab is an I32 *
+ * To make inserting the link to slab PL_OpPtr is I32 **
+ * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
+ * Add an overhead for pointer to slab and round up as a number of pointers
+ */
+ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
+ if ((PL_OpSpace -= sz) < 0) {
+ PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+ if (!PL_OpPtr) {
+ return NULL;
+ }
+ Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
+ /* We reserve the 0'th I32 sized chunk as a use count */
+ PL_OpSlab = (I32 *) PL_OpPtr;
+ /* Reduce size by the use count word, and by the size we need.
+ * Latter is to mimic the '-=' in the if() above
+ */
+ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
+ /* Allocation pointer starts at the top.
+ Theory: because we build leaves before trunk allocating at end
+ means that at run time access is cache friendly upward
+ */
+ PL_OpPtr += PERL_SLAB_SIZE;
+ }
+ assert( PL_OpSpace >= 0 );
+ /* Move the allocation pointer down */
+ PL_OpPtr -= sz;
+ assert( PL_OpPtr > (I32 **) PL_OpSlab );
+ *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
+ (*PL_OpSlab)++; /* Increment use count of slab */
+ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
+ assert( *PL_OpSlab > 0 );
+ return (void *)(PL_OpPtr + 1);
+}
+
+STATIC void
+S_Slab_Free(pTHX_ void *op)
+{
+ I32 **ptr = (I32 **) op;
+ I32 *slab = ptr[-1];
+ assert( ptr-1 > (I32 **) slab );
+ assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+ assert( *slab > 0 );
+ if (--(*slab) == 0) {
+ PerlMemShared_free(slab);
+ if (slab == PL_OpSlab) {
+ PL_OpSpace = 0;
+ }
+ }
}
#else
#define NewOp(m, var, c, type) Newz(m, var, c, type)
+#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
cop_free((COP*)o);
op_clear(o);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
+ FreeOp(o);
}
void
pmop = pmop->op_pmnext;
}
}
-#ifdef USE_ITHREADS
- Safefree(PmopSTASHPV(cPMOPo));
-#else
- /* NOTE: PMOP.op_pmstash is not refcounted */
-#endif
+ PmopSTASH_free(cPMOPo);
}
cPMOPo->op_pmreplroot = Nullop;
/* we use the "SAFE" version of the PM_ macros here
SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
}
-#endif
+#endif
break;
}
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label);
-#ifdef USE_ITHREADS
- Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
- Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
-#else
- /* NOTE: COP.cop_stash is not refcounted */
- SvREFCNT_dec(CopFILEGV(cop));
-#endif
+ Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopFILE_free(cop);
+ CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
SvREFCNT_dec(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io))
+ if (! specialCopIO(cop->cop_io)) {
+#ifdef USE_ITHREADS
+ STRLEN len;
+ char *s = SvPV(cop->cop_io,len);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
+#else
SvREFCNT_dec(cop->cop_io);
+#endif
+ }
}
void
|| kid->op_type == OP_METHOD)
{
UNOP *newop;
-
+
NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
newop->op_private |= OPpLVAL_INTRO;
break;
}
-
+
if (kid->op_type != OP_RV2CV)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
-
- okid = kid;
+
+ okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL)
+ if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
"entry via type/targ %ld:%"UVuf,
okid->op_private |= OPpLVAL_INTRO;
break;
}
-
+
cv = GvCV(kGVOP_gv);
if (!cv)
goto restore_2cv;
goto nomod;
PL_modcount++;
break;
-
+
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
case OP_PUSHMARK:
break;
-
+
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(form("Can't declare %s in my", OP_DESC(o)));
+ yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
}
if (attrs) {
GV *gv = cGVOPx_gv(cUNOPo->op_first);
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
-#ifdef PL_OP_SLAB_ALLOC
-#else
- Safefree(last);
-#endif
+ FreeOp(last);
+
return (OP*)first;
}
pmop->op_pmoffset = SvIV(repointer);
SvREPADTMP_off(repointer);
sv_setiv(repointer,0);
- } else {
+ } else {
repointer = newSViv(0);
av_push(PL_regex_padav,SvREFCNT_inc(repointer));
pmop->op_pmoffset = av_len(PL_regex_padav);
}
}
#endif
-
+
/* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
- if (DO_UTF8(pat) || (PL_hints & HINT_UTF8))
+ if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
op_free(expr);
}
else {
- if (PL_hints & HINT_UTF8)
- pm->op_pmdynflags |= PMdf_UTF8;
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
? OP_REGCRESET
}
/*
+=head1 Embedding Functions
+
=for apidoc load_module
Loads the module whose name is pointed to by the string part of name.
if (gv == PL_defgv || SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
- }
+ }
}
else
break;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
+ if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
- }
+ }
}
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LOOP);
+ FreeOp(loop);
loop = tmp;
}
#else
void
Perl_cv_undef(pTHX_ CV *cv)
{
+ CV *outsidecv;
+ CV *freecv = Nullcv;
+ bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
+
#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
}
SvPOK_off((SV*)cv); /* forget prototype */
CvGV(cv) = Nullgv;
+ outsidecv = CvOUTSIDE(cv);
/* Since closure prototypes have the same lifetime as the containing
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
* closure prototype, and the ensuing memory leak. --GSAR */
if (!CvANON(cv) || CvCLONED(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
+ freecv = outsidecv;
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILLp(CvPADLIST(cv));
- while (i >= 0) {
- SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
- SV* sv = svp ? *svp : Nullsv;
+ AV *padlist = CvPADLIST(cv);
+ I32 ix;
+ if (is_eval) {
+ /* inner references to eval's cv must be fixed up */
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **namepad = AvARRAY(comppad_name);
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&'
+ && ix <= AvFILLp(comppad))
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (innercv && SvTYPE(innercv) == SVt_PVCV
+ && CvOUTSIDE(innercv) == cv)
+ {
+ CvOUTSIDE(innercv) = outsidecv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(outsidecv);
+ if (SvREFCNT(cv))
+ SvREFCNT_dec(cv);
+ }
+ }
+ }
+ }
+ }
+ if (freecv)
+ SvREFCNT_dec(freecv);
+ ix = AvFILLp(padlist);
+ while (ix >= 0) {
+ SV* sv = AvARRAY(padlist)[ix--];
if (!sv)
continue;
if (sv == (SV*)PL_comppad_name)
}
CvPADLIST(cv) = Nullav;
}
+ else if (freecv)
+ SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
}
static void const_sv_xsub(pTHX_ CV* cv);
/*
+
+=head1 Optree Manipulation Functions
+
=for apidoc cv_const_sv
If C<cv> is a constant sub eligible for inlining. returns the constant
SAVESPTR(PL_curstash);
SAVECOPSTASH(PL_curcop);
PL_curstash = stash;
-#ifdef USE_ITHREADS
- CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
-#else
- CopSTASH(PL_curcop) = stash;
-#endif
+ CopSTASH_set(PL_curcop,stash);
}
cv = newXS(name, const_sv_xsub, __FILE__);
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
-
+
case OP_RV2SV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
!(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
+
return o;
}
op_free(kUNOP->op_first);
Perl_warner(aTHX_ WARN_SYNTAX,
"Useless use of %s with no values",
PL_op_desc[type]);
-
+
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
OP *newop = newGVOP(OP_GV, 0,
gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
SVt_PVIO) );
+ if (kid == cLISTOPo->op_last)
+ cLISTOPo->op_last = newop;
op_free(kid);
kid = newop;
}
if (!gv) {
GV *glob_gv;
ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
- Nullsv, Nullsv);
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
kid = kid->op_sibling;
}
}
-
+
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+
op_free(o);
#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
goto again;
break;
case ']':
- if (contextclass)
- contextclass = 0;
- else
+ if (contextclass) {
+ char *p = proto;
+ char s = *p;
+ contextclass = 0;
+ *p = '\0';
+ while (*--p != '[');
+ bad_type(arg, Perl_form(aTHX_ "one of %s", p),
+ gv_ename(namegv), o2);
+ *proto = s;
+ } else
goto oops;
break;
case '*':
else if (o->op_next->op_type == OP_RV2AV) {
OP* pop = o->op_next->op_next;
IV i;
- if (pop->op_type == OP_CONST &&
+ if (pop && pop->op_type == OP_CONST &&
(PL_op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
}
}
break;
-
+
case OP_HELEM: {
UNOP *rop;
SV *lexname;
I32 ind;
char *key = NULL;
STRLEN keylen;
-
+
o->op_seq = PL_op_seqmax++;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
*svp = sv;
break;
}
-
+
case OP_HSLICE: {
UNOP *rop;
SV *lexname;
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-