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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/op.h
+++ b/op.h
@@ -222,6 +222,8 @@ Deprecated.  Use C<GIMME_V> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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)],