void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
+ dVAR;
/*
* To make incrementing use count easy PL_OpSlab is an I32 *
* To make inserting the link to slab PL_OpPtr is I32 **
#ifdef PERL_DEBUG_READONLY_OPS
/* We need to allocate chunk by chunk so that we can control the VM
mapping */
- PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
+ PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
MAP_ANON|MAP_PRIVATE, -1, 0);
DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
#ifdef PERL_DEBUG_READONLY_OPS
/* We remember this slab. */
/* This implementation isn't efficient, but it is simple. */
- PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
+ PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
PL_slabs[PL_slab_count++] = PL_OpSlab;
DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
#endif
if (count) {
while (count--) {
if (PL_slabs[count] == slab) {
+ dVAR;
/* Found it. Move the entry at the end to overwrite it. */
DEBUG_m(PerlIO_printf(Perl_debug_log,
"Deallocate %p by moving %p from %lu to %lu\n",
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
}
clear_pmop:
forget_pmop(cPMOPo, 1);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
- /* we use the "SAFE" version of the PM_ macros here
- * since sv_clean_all might release some PMOPs
+ /* we use the same protection as the "SAFE" version of the PM_ macros
+ * here since sv_clean_all might release some PMOPs
* after PL_regex_padav has been cleared
* and the clearing of PL_regex_padav needs to
* happen before sv_clean_all
*/
- ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
- PM_SETRE_SAFE(cPMOPo, NULL);
#ifdef USE_ITHREADS
if(PL_regex_pad) { /* We could be in destruction */
- av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
- SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
- SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
- PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
+ const IV offset = (cPMOPo)->op_pmoffset;
+ ReREFCNT_dec(PM_GETRE(cPMOPo));
+ PL_regex_pad[offset] = &PL_sv_undef;
+ sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
+ sizeof(offset));
}
+#else
+ ReREFCNT_dec(PM_GETRE(cPMOPo));
+ PM_SETRE(cPMOPo, NULL);
#endif
break;
}
if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_SETSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_SETSTATE
|| o->op_targ == OP_DBSTATE)))
PL_curcop = (COP*)o; /* for warning below */
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
+ case OP_SMARTMATCH:
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
case OP_PROTOTYPE:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
useless = OP_DESC(o);
break;
Perl_fold_constants(pTHX_ register OP *o)
{
dVAR;
- register OP *curop;
+ register OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
#ifdef USE_ITHREADS
- if (av_len((AV*) PL_regex_pad[0]) > -1) {
- SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
- pmop->op_pmoffset = SvIV(repointer);
- SvREPADTMP_off(repointer);
- sv_setiv(repointer,0);
+ assert(SvPOK(PL_regex_pad[0]));
+ if (SvCUR(PL_regex_pad[0])) {
+ /* Pop off the "packed" IV from the end. */
+ SV *const repointer_list = PL_regex_pad[0];
+ const char *p = SvEND(repointer_list) - sizeof(IV);
+ const IV offset = *((IV*)p);
+
+ assert(SvCUR(repointer_list) % sizeof(IV) == 0);
+
+ SvEND_set(repointer_list, p);
+
+ pmop->op_pmoffset = offset;
+ /* This slot should be free, so assert this: */
+ assert(PL_regex_pad[offset] == &PL_sv_undef);
} else {
- SV * const repointer = newSViv(0);
- av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
+ SV * const repointer = &PL_sv_undef;
+ av_push(PL_regex_padav, repointer);
pmop->op_pmoffset = av_len(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
}
const char *const p = SvPV(pat, len);
pat = newSVpvn_flags(p, len, SVs_TEMP);
}
- assert(!(pm_flags & RXf_UTF8));
PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
static const char no_list_state[] = "Initialization of state variables"
" in list context currently forbidden";
OP *curop;
+ bool maybe_common_vars = TRUE;
PL_modcount = 0;
/* Grandfathering $[ assignment here. Bletch.*/
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
+ if ((left->op_type == OP_LIST
+ || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+ {
+ OP* lop = ((LISTOP*)left)->op_first;
+ maybe_common_vars = FALSE;
+ while (lop) {
+ if (lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY) {
+ if (!(lop->op_private & OPpLVAL_INTRO))
+ maybe_common_vars = TRUE;
+
+ if (lop->op_private & OPpPAD_STATE) {
+ if (left->op_private & OPpLVAL_INTRO) {
+ /* Each variable in state($a, $b, $c) = ... */
+ }
+ else {
+ /* Each state variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ yyerror(no_list_state);
+ } else {
+ /* Each my variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ } else if (lop->op_type == OP_UNDEF ||
+ lop->op_type == OP_PUSHMARK) {
+ /* undef may be interesting in
+ (state $a, undef, state $c) */
+ } else {
+ /* Other ops in the list. */
+ maybe_common_vars = TRUE;
+ }
+ lop = lop->op_sibling;
+ }
+ }
+ else if ((left->op_private & OPpLVAL_INTRO)
+ && ( left->op_type == OP_PADSV
+ || left->op_type == OP_PADAV
+ || left->op_type == OP_PADHV
+ || left->op_type == OP_PADANY))
+ {
+ maybe_common_vars = FALSE;
+ if (left->op_private & OPpPAD_STATE) {
+ /* All single variable list context state assignments, hence
+ state ($a) = ...
+ (state $a) = ...
+ state @a = ...
+ state (@a) = ...
+ (state @a) = ...
+ state %a = ...
+ state (%a) = ...
+ (state %a) = ...
+ */
+ yyerror(no_list_state);
+ }
+ }
+
/* PL_generation sorcery:
* an assignment like ($a,$b) = ($c,$d) is easier than
* ($a,$b) = ($c,$a), since there is no need for temporary vars.
* to store these values, evil chicanery is done with SvUVX().
*/
- {
+ if (maybe_common_vars) {
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
o->op_private |= OPpASSIGN_COMMON;
}
- if ((left->op_type == OP_LIST
- || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
- OP* lop = ((LISTOP*)left)->op_first;
- while (lop) {
- if (lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY) {
- if (lop->op_private & OPpPAD_STATE) {
- if (left->op_private & OPpLVAL_INTRO) {
- /* Each variable in state($a, $b, $c) = ... */
- }
- else {
- /* Each state variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- yyerror(no_list_state);
- } else {
- /* Each my variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- } else {
- /* Other ops in the list. undef may be interesting in
- (state $a, undef, state $c) */
- }
- lop = lop->op_sibling;
- }
- }
- else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
- == (OPpLVAL_INTRO | OPpPAD_STATE))
- && ( left->op_type == OP_PADSV
- || left->op_type == OP_PADAV
- || left->op_type == OP_PADHV
- || left->op_type == OP_PADANY))
- {
- /* All single variable list context state assignments, hence
- state ($a) = ...
- (state $a) = ...
- state @a = ...
- state (@a) = ...
- (state @a) = ...
- state %a = ...
- state (%a) = ...
- (state %a) = ...
- */
- yyerror(no_list_state);
- }
-
if (right && right->op_type == OP_SPLIT && !PL_madskills) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
o->op_opt = 1;
PL_op = o;
switch (o->op_type) {
- case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
goto nothin;
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE
- || o->op_targ == OP_SETSTATE)
+ || o->op_targ == OP_DBSTATE)
{
PL_curcop = ((COP*)o);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff