recursive, but it's recursive on basic blocks, not on tree nodes.
*/
+/* To implement user lexical pragmas, there needs to be a way at run time to
+ get the compile time state of %^H for that block. Storing %^H in every
+ block (or even COP) would be very expensive, so a different approach is
+ taken. The (running) state of %^H is serialised into a tree of HE-like
+ structs. Stores into %^H are chained onto the current leaf as a struct
+ refcounted_he * with the key and the value. Deletes from %^H are saved
+ with a value of PL_sv_placeholder. The state of %^H at any point can be
+ turned back into a regular HV by walking back up the tree from that point's
+ leaf, ignoring any key you've already seen (placeholder or not), storing
+ the rest into the HV structure, then removing the placeholders. Hence
+ memory is only used to store the %^H deltas from the enclosing COP, rather
+ than the entire %^H on each COP.
+
+ To cause actions on %^H to write out the serialisation records, it has
+ magic type 'H'. This magic (itself) does nothing, but its presence causes
+ the values to gain magic type 'h', which has entries for set and clear.
+ C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ saves the current C<PL_compiling.cop_hints> on the save stack, so that it
+ will be correctly restored when any inner compiling scope is exited.
+*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
SvREFCNT_dec(cop->cop_io);
#endif
}
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints);
}
void
if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (o->op_private & OPpCONST_ARYBASE)
- useless = 0;
+ useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = 0;
+ useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
- useless = 0;
+ useless = NULL;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
(before the invention of POD) was based on a
if (strnEQ(maybe_macro, "di", 2) ||
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
- useless = 0;
+ useless = NULL;
}
}
}
goto nomod;
localize = 0;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
+ CopARYBASE_set(&PL_compiling,
+ (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
PL_eval_start = 0;
}
else if (!type) {
- SAVEI32(PL_compiling.cop_arybase);
- PL_compiling.cop_arybase = 0;
+ SAVECOPARYBASE(&PL_compiling);
+ CopARYBASE_set(&PL_compiling, 0);
}
else if (type == OP_REFGEN)
goto nomod;
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
#ifdef PERL_MAD
else if (o->op_type == OP_NULL)
- rop = Nullop;
+ rop = NULL;
#endif
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
if (!o || PL_error_count)
return o;
+ type = o->op_type;
if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
(void)my_kid(cUNOPo->op_first, attrs, imopsp);
return o;
}
- type = o->op_type;
if (type == OP_LIST) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
Perl_invert(pTHX_ OP *o)
{
if (!o)
- return o;
- /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return NULL;
return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
{
if (o->op_type == OP_LIST) {
OP * const o2
- = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
- SVt_PV)));
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
OP *newop;
I32 type = o->op_type;
SV *sv;
+ int ret = 0;
+ I32 oldscope;
+ OP *old_next;
+ dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
}
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
PL_op = curop;
- CALLRUNOPS(aTHX);
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- SvREFCNT_inc_simple_void(sv);
- SvTEMP_off(sv);
+
+ oldscope = PL_scopestack_ix;
+ create_eval_scope(G_FAKINGEVAL);
+
+ JMPENV_PUSH(ret);
+
+ switch (ret) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ, FALSE);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ SvREFCNT_inc_simple_void(sv);
+ SvTEMP_off(sv);
+ }
+ break;
+ case 3:
+ /* Something tried to die. Abandon constant folding. */
+ /* Pretend the error never happened. */
+ sv_setpvn(ERRSV,"",0);
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
+ JMPENV_POP;
+
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
+
+ if (ret)
+ goto nope;
+
#ifndef PERL_MAD
op_free(o);
#endif
op_getmad(o,newop,'f');
return newop;
- nope:
+ nope:
return o;
}
const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
+ const U32 flags = UTF8_ALLOW_DEFAULT;
if (!from_utf) {
STRLEN len = tlen;
i = 0;
transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
}
else {
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
}
else
#else
if (!PL_madskills) {
op_free(o);
- return Nullop;
+ return NULL;
}
pegop = newOP(OP_NULL,0);
if (!PL_madskills) {
/* FIXME - don't allocate pegop if !PL_madskills */
op_free(pegop);
- return Nullop;
+ return NULL;
}
return pegop;
#endif
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ newGVOP(OP_GV, 0, gv))))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
else {
/* FIXME for MAD */
op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
o->op_private |= OPpCONST_ARYBASE;
}
}
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = (U8)flags;
- cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(cop, PL_hints);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- PL_compiling.op_private = cop->op_private;
+ CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
if (label) {
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
- cop->cop_arybase = PL_curcop->cop_arybase;
+ CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
if (specialWARN(PL_curcop->cop_warnings))
cop->cop_warnings = PL_curcop->cop_warnings ;
else
cop->cop_io = PL_curcop->cop_io;
else
cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+ cop->cop_hints = PL_curcop->cop_hints;
+ if (cop->cop_hints) {
+ cop->cop_hints->refcounted_he_refcnt++;
+ }
if (PL_copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
break;
case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
+ if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
break;
case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
+ if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
- OP *madsv = 0;
+ OP *madsv = NULL;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
* set the STACKED flag to indicate that these values are to be
* treated as min/max values by 'pp_iterinit'.
*/
- UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
OP* const right = left->op_sibling;
*/
STATIC
bool
-S_looks_like_bool(pTHX_ OP *o)
+S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
switch(o->op_type) {
OP *
Perl_newWHENOP(pTHX_ OP *cond, OP *block)
{
- bool cond_llb = (!cond || looks_like_bool(cond));
+ const bool cond_llb = (!cond || looks_like_bool(cond));
OP *cond_op;
if (cond_llb)
}
}
if (const_sv) {
- SvREFCNT_inc_void_NN(const_sv);
+ SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
{
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
return o;
}
Perl_ck_eof(pTHX_ OP *o)
{
dVAR;
- const I32 type = o->op_type;
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
- OP* newop
- = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+ OP * const newop
+ = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
#ifdef PERL_MAD
op_getmad(o,newop,'O');
#else
else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#endif
cUNOPo->op_first = 0;
}
else {
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#else
op_free(o);
#endif
o->op_targ = (PADOFFSET)PL_hints;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up */
- OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+ OP *hhop = newSVOP(OP_CONST, 0,
+ (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
#else
op_free(o);
#endif
- o = newop;
- return o;
+ return newop;
}
- else {
- if ((PL_hints & HINT_FILETEST_ACCESS) &&
- OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
- }
if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
&& kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
o->op_private |= OPpFT_STACKED;
}
else {
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#else
op_free(o);
#endif
listkids(o);
}
else if (PL_opargs[type] & OA_DEFGV) {
- OP *newop = newUNOP(type, 0, newDEFSVOP());
#ifdef PERL_MAD
+ OP *newop = newUNOP(type, 0, newDEFSVOP());
op_getmad(o,newop,'O');
+ return newop;
#else
+ /* Ordering of these two is important to keep f_map.t passing. */
op_free(o);
+ return newUNOP(type, 0, newDEFSVOP());
#endif
- return newop;
}
if (oa) {
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop;
+ LOGOP *gwop = NULL;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
I32 offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
- NewOp(1101, gwop, 1, LOGOP);
+ /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
if (o->op_flags & OPf_STACKED) {
OP* k;
for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
+ NewOp(1101, gwop, 1, LOGOP);
kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
Perl_croak(aTHX_ "panic: ck_grep");
kid = kUNOP->op_first;
+ if (!gwop)
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
gwop->op_first = listkids(o);
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
OP * const kid = cUNOPo->op_first;
- OP * newop
- = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ OP * newop;
+
cUNOPo->op_first = 0;
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
+#ifndef PERL_MAD
op_free(o);
#endif
+ newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, kid,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0,
+ gv))))));
+ op_getmad(o,newop,'O');
return newop;
}
OP *argop;
/* FIXME - this can be refactored to reduce code in #ifdefs */
#ifdef PERL_MAD
- OP *oldo = o;
+ OP * const oldo = o;
#else
op_free(o);
#endif
OP * const sibling = o2->op_sibling;
SV * const n = newSVpvs("");
#ifdef PERL_MAD
- OP *oldo2 = o2;
+ OP * const oldo2 = o2;
#else
op_free(o2);
#endif
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
- OP *oldo = o;
+ OP * const oldo = o;
#else
op_free(o);
#endif
Perl_ck_substr(pTHX_ OP *o)
{
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
+ if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
+ (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
<= 255 &&
i >= 0)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff