From: Father Chrysostomos Date: Sun, 26 Aug 2012 01:48:46 +0000 (-0700) Subject: Banish boolkeys X-Git-Tag: upstream/5.20.0~5625 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=c8fe3bdf72b0df1c0b68f180001f0a3dde206992;p=platform%2Fupstream%2Fperl.git Banish boolkeys Since 6ea72b3a1, rv2hv and padhv have had the ability to return boo- leans in scalar context, instead of bucket stats, if flagged the right way. sub { %hash || ... } is optimised to take advantage of this. If the || is in unknown context at compile time, the %hash is flagged as being maybe a true boolean. When flagged that way, it returns a bool- ean if block_gimme() returns G_VOID. If rv2hv and padhv can already do this, then we don’t need the boolkeys op any more. We can just flag the rv2hv to return a boolean. In all the cases where boolkeys was used, we know at compile time that it is true boolean context, so we add a new flag for that. --- diff --git a/dump.c b/dump.c index 6ac3d33..1283d1d 100644 --- a/dump.c +++ b/dump.c @@ -943,9 +943,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) if (o->op_private & OPpLVAL_DEFER) sv_catpv(tmpsv, ",LVAL_DEFER"); } - else if ((optype == OP_RV2HV || optype == OP_PADHV) - && o->op_private & OpMAYBE_TRUEBOOL) { + else if (optype == OP_RV2HV || optype == OP_PADHV) { + if (o->op_private & OpMAYBE_TRUEBOOL) sv_catpvs(tmpsv, ",OpMAYBE_TRUEBOOL"); + if (o->op_private & OPpTRUEBOOL) + sv_catpvs(tmpsv, ",OPpTRUEBOOL"); } else { if (o->op_private & HINT_STRICT_REFS) diff --git a/embed.fnc b/embed.fnc index 8f08898..dac6182 100644 --- a/embed.fnc +++ b/embed.fnc @@ -675,7 +675,6 @@ p |OP* |jmaybe |NN OP *o : Used in pp.c pP |I32 |keyword |NN const char *name|I32 len|bool all_keywords #if defined(PERL_IN_OP_C) -s |OP* |opt_scalarhv |NN OP* rep_op s |void |inplace_aassign |NN OP* o #endif Ap |void |leave_scope |I32 base diff --git a/embed.h b/embed.h index 78abe14..118d733 100644 --- a/embed.h +++ b/embed.h @@ -1426,7 +1426,6 @@ #define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a) #define op_integerize(a) S_op_integerize(aTHX_ a) #define op_std_init(a) S_op_std_init(aTHX_ a) -#define opt_scalarhv(a) S_opt_scalarhv(aTHX_ a) #define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c) #define process_special_blocks(a,b,c) S_process_special_blocks(aTHX_ a,b,c) #define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 1b4bd9c..7de36df 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -629,7 +629,7 @@ $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv", "enteriter"); $priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice av2arylen keys rkeys substr pos vec); -$priv{$_}{64} = 'BOOL' for 'rv2hv', 'padhv'; +@{$priv{$_}}{32,64} = ('BOOL','BOOL?') for 'rv2hv', 'padhv'; $priv{substr}{16} = 'REPL1ST'; $priv{$_}{16} = "TARGMY" for (map(($_,"s$_"),"chop", "chomp"), diff --git a/op.c b/op.c index c62e943..cd37eb8 100644 --- a/op.c +++ b/op.c @@ -10206,34 +10206,6 @@ Perl_ck_length(pTHX_ OP *o) return o; } -/* caller is supposed to assign the return to the - container of the rep_op var */ -STATIC OP * -S_opt_scalarhv(pTHX_ OP *rep_op) { - dVAR; - UNOP *unop; - - PERL_ARGS_ASSERT_OPT_SCALARHV; - - NewOp(1101, unop, 1, UNOP); - unop->op_type = (OPCODE)OP_BOOLKEYS; - unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS]; - unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS ); - unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8)); - unop->op_first = rep_op; - unop->op_next = rep_op->op_next; - rep_op->op_next = (OP*)unop; - rep_op->op_flags|=(OPf_REF | OPf_MOD); - unop->op_sibling = rep_op->op_sibling; - rep_op->op_sibling = NULL; - unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); - if (rep_op->op_type == OP_PADHV) { - rep_op->op_flags &= ~OPf_WANT_SCALAR; - rep_op->op_flags |= OPf_WANT_LIST; - } - return (OP*)unop; -} - /* Check for in place reverse and sort assignments like "@a = reverse @a" and modify the optree to make them work inplace */ @@ -10524,7 +10496,6 @@ Perl_rpeep(pTHX_ register OP *o) { OP *fop; OP *sop; - bool fopishv, sopishv; case OP_NOT: fop = cUNOP->op_first; @@ -10548,13 +10519,16 @@ Perl_rpeep(pTHX_ register OP *o) o->op_opt = 1; #define HV_OR_SCALARHV(op) \ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ - || ( (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ + ? (op) \ + : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ && ( cUNOPx(op)->op_first->op_type == OP_PADHV \ - || cUNOPx(op)->op_first->op_type == OP_RV2HV))) \ + || cUNOPx(op)->op_first->op_type == OP_RV2HV) \ + ? cUNOPx(op)->op_first \ + : NULL) - fopishv = HV_OR_SCALARHV(fop); - sopishv = sop && HV_OR_SCALARHV(sop); - if (fopishv || sopishv + fop = HV_OR_SCALARHV(fop); + if (sop) sop = HV_OR_SCALARHV(sop); + if (fop || sop ){ OP * nop = o; OP * lop = o; @@ -10576,29 +10550,27 @@ Perl_rpeep(pTHX_ register OP *o) } } } - if ( ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID + if (fop) { + if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID || o->op_type == OP_AND ) - && fopishv) - cLOGOP->op_first = opt_scalarhv(fop); - else if (!(lop->op_flags & OPf_WANT)) { - if (fop->op_type == OP_SCALAR) - fop = cUNOPx(fop)->op_first; - fop->op_private |= OpMAYBE_TRUEBOOL; + fop->op_private |= OPpTRUEBOOL; + else if (!(lop->op_flags & OPf_WANT)) + fop->op_private |= OpMAYBE_TRUEBOOL; } if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID - && sopishv) - cLOGOP->op_first->op_sibling = opt_scalarhv(sop); + && sop) + sop->op_private |= OPpTRUEBOOL; } break; - } case OP_COND_EXPR: - if (HV_OR_SCALARHV(cLOGOP->op_first)) - cLOGOP->op_first = opt_scalarhv(cLOGOP->op_first); + if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) + fop->op_private |= OpMAYBE_TRUEBOOL; #undef HV_OR_SCALARHV /* GERONIMO! */ + } case OP_MAPWHILE: case OP_GREPWHILE: diff --git a/op.h b/op.h index d977e57..60af704 100644 --- a/op.h +++ b/op.h @@ -222,6 +222,8 @@ Deprecated. Use C instead. OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */ #define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */ /* OP_RV2HV and OP_PADHV */ +#define OPpTRUEBOOL 32 /* %hash in (%hash || $foo) in + void context */ #define OpMAYBE_TRUEBOOL 64 /* %hash in (%hash || $foo) where cx is not known till run time */ diff --git a/opcode.h b/opcode.h index ec82a29..30f3f7e 100644 --- a/opcode.h +++ b/opcode.h @@ -43,6 +43,7 @@ #define Perl_pp_values Perl_do_kv #define Perl_pp_keys Perl_do_kv #define Perl_pp_rv2hv Perl_pp_rv2av +#define Perl_pp_boolkeys Perl_unimplemented_op #define Perl_pp_pop Perl_pp_shift #define Perl_pp_mapstart Perl_unimplemented_op #define Perl_pp_dor Perl_pp_defined @@ -1069,7 +1070,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_rv2hv, /* implemented by Perl_pp_rv2av */ Perl_pp_helem, Perl_pp_hslice, - Perl_pp_boolkeys, + Perl_pp_boolkeys, /* implemented by Perl_unimplemented_op */ Perl_pp_unpack, Perl_pp_pack, Perl_pp_split, diff --git a/pp.c b/pp.c index e61894a..0d31c26 100644 --- a/pp.c +++ b/pp.c @@ -131,9 +131,11 @@ PP(pp_padhv) if (gimme == G_ARRAY) { RETURNOP(Perl_do_kv(aTHX)); } - else if (PL_op->op_private & OpMAYBE_TRUEBOOL - && block_gimme() == G_VOID) - SETs(boolSV(HvUSEDKEYS(TARG))); + else if ((PL_op->op_private & OPpTRUEBOOL + || ( PL_op->op_private & OpMAYBE_TRUEBOOL + && block_gimme() == G_VOID )) + && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))) + SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0))); else if (gimme == G_SCALAR) { SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG)); SETs(sv); @@ -281,8 +283,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, } if (!SvOK(sv)) { if ( - PL_op->op_flags & OPf_REF && - PL_op->op_next->op_type != OP_BOOLKEYS + PL_op->op_flags & OPf_REF ) Perl_die(aTHX_ PL_no_usym, what); if (ckWARN(WARN_UNINITIALIZED)) @@ -5721,28 +5722,6 @@ PP(unimplemented_op) DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); } -PP(pp_boolkeys) -{ - dVAR; - dSP; - dTARGET; - HV * const hv = (HV*)TOPs; - - if (SvTYPE(hv) != SVt_PVHV) RETSETNO; - - if (SvRMAGICAL(hv)) { - MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied); - if (mg) { - SETs(magic_scalarpack(hv, mg)); - RETURN; - } - } - - if (HvUSEDKEYS(hv) != 0) RETSETYES; - else SETi(0); /* for $ret = %hash && foo() */ - RETURN; -} - /* For sorting out arguments passed to a &CORE:: subroutine */ PP(pp_coreargs) { diff --git a/pp_hot.c b/pp_hot.c index 754536a..ea574d7 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -873,9 +873,11 @@ PP(pp_rv2av) *PL_stack_sp = sv; return Perl_do_kv(aTHX); } - else if (PL_op->op_private & OpMAYBE_TRUEBOOL - && block_gimme() == G_VOID) - SETs(boolSV(HvUSEDKEYS(sv))); + else if ((PL_op->op_private & OPpTRUEBOOL + || ( PL_op->op_private & OpMAYBE_TRUEBOOL + && block_gimme() == G_VOID )) + && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied))) + SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0))); else if (gimme == G_SCALAR) { dTARGET; TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); diff --git a/pp_proto.h b/pp_proto.h index 52011da..833738d 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -27,7 +27,6 @@ PERL_CALLCONV OP *Perl_pp_binmode(pTHX); PERL_CALLCONV OP *Perl_pp_bit_and(pTHX); PERL_CALLCONV OP *Perl_pp_bit_or(pTHX); PERL_CALLCONV OP *Perl_pp_bless(pTHX); -PERL_CALLCONV OP *Perl_pp_boolkeys(pTHX); PERL_CALLCONV OP *Perl_pp_break(pTHX); PERL_CALLCONV OP *Perl_pp_caller(pTHX); PERL_CALLCONV OP *Perl_pp_chdir(pTHX); diff --git a/proto.h b/proto.h index 0544378..c88c22f 100644 --- a/proto.h +++ b/proto.h @@ -5894,11 +5894,6 @@ PERL_STATIC_INLINE OP* S_op_std_init(pTHX_ OP *o) #define PERL_ARGS_ASSERT_OP_STD_INIT \ assert(o) -STATIC OP* S_opt_scalarhv(pTHX_ OP* rep_op) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_OPT_SCALARHV \ - assert(rep_op) - STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) diff --git a/regen/opcode.pl b/regen/opcode.pl index 2ef64ec..a776582 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -67,7 +67,8 @@ my %alias; # Format is "this function" => "does these op names" my @raw_alias = ( Perl_do_kv => [qw( keys values )], - Perl_unimplemented_op => [qw(padany mapstart custom)], + Perl_unimplemented_op => [qw(padany mapstart custom + boolkeys)], # All the ops with a body of { return NORMAL; } Perl_pp_null => [qw(scalar regcmaybe lineseq scope)],