Optimise if (%foo) to be faster than if(keys %foo)

Thread was "[PATCH] Make if (%hash) {} act the same as if (keys %hash) {}"
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-11/msg00432.html
but the implementation evolved from the approach described in the subject, to
instead add a new opcode pp_boolkeys, to exactly preserve the existing
behaviour.

Various conflicts with the passage of time resolved, 'register' removed, and a
$VERSION bump.

diff --git a/embed.fnc b/embed.fnc
index 1147a98..bb2a4d9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -502,6 +502,9 @@ ApR |bool   |is_utf8_mark   |NN const U8 *p
 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) || defined(PERL_DECL_PROT)
+s      |OP*    |opt_scalarhv   |NN OP* rep_op
+#endif
 Ap     |void   |leave_scope    |I32 base
 : Used in pp_ctl.c, and by Data::Alias
 EXp    |void   |lex_end

diff --git a/embed.h b/embed.h
index 61780ee..d896d79 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -391,6 +391,11 @@
 #define jmaybe                 Perl_jmaybe
 #define keyword                        Perl_keyword
 #endif
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define opt_scalarhv           S_opt_scalarhv
+#endif
+#endif
 #define leave_scope            Perl_leave_scope
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define lex_end                        Perl_lex_end
@@ -2050,6 +2055,7 @@
 #define pp_bit_or              Perl_pp_bit_or
 #define pp_bit_xor             Perl_pp_bit_xor
 #define pp_bless               Perl_pp_bless
+#define pp_boolkeys            Perl_pp_boolkeys
 #define pp_break               Perl_pp_break
 #define pp_caller              Perl_pp_caller
 #define pp_chdir               Perl_pp_chdir
@@ -2746,6 +2752,11 @@
 #define jmaybe(a)              Perl_jmaybe(aTHX_ a)
 #define keyword(a,b,c)         Perl_keyword(aTHX_ a,b,c)
 #endif
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define opt_scalarhv(a)                S_opt_scalarhv(aTHX_ a)
+#endif
+#endif
 #define leave_scope(a)         Perl_leave_scope(aTHX_ a)
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define lex_end()              Perl_lex_end(aTHX)
@@ -4419,6 +4430,7 @@
 #define pp_bit_or()            Perl_pp_bit_or(aTHX)
 #define pp_bit_xor()           Perl_pp_bit_xor(aTHX)
 #define pp_bless()             Perl_pp_bless(aTHX)
+#define pp_boolkeys()          Perl_pp_boolkeys(aTHX)
 #define pp_break()             Perl_pp_break(aTHX)
 #define pp_caller()            Perl_pp_caller(aTHX)
 #define pp_chdir()             Perl_pp_chdir(aTHX)

diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index b50cbb2..d900113 100644 (file)
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -148,7 +148,7 @@ my $testpkgs = {
                  ), $] > 5.009 ? ('unitcheck_av') : ()],
     },
 
-    B::Deparse => { dflt => 'perl',    # 235 functions
+    B::Deparse => { dflt => 'perl',    # 236 functions
 
        XS => [qw( svref_2object perlstring opnumber main_start
                   main_root main_cv )],

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index d778294..31b6f44 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.13";
+$VERSION = "1.14";
 
 use Carp;
 use Exporter ();
@@ -311,6 +311,7 @@ invert_opset function.
     rv2av aassign aelem aelemfast aslice av2arylen
 
     rv2hv helem hslice each values keys exists delete aeach akeys avalues
+    boolkeys
 
     preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
     int hex oct abs pow multiply i_multiply divide i_divide

diff --git a/op.c b/op.c
index bb9a292..796bec3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8276,6 +8276,33 @@ Perl_ck_each(pTHX_ OP *o)
     return ck_fun(o);
 }
 
+/* caller is supposed to assign the return to the 
+   container of the rep_op var */
+OP *
+S_opt_scalarhv(pTHX_ OP *rep_op) {
+    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;
+}                        
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -8462,12 +8489,67 @@ Perl_peep(pTHX_ register OP *o)
            }
 
            break;
+        
+        {
+            OP *fop;
+            OP *sop;
+            
+        case OP_NOT:
+            fop = cUNOP->op_first;
+            sop = NULL;
+            goto stitch_keys;
+            break;
 
-       case OP_MAPWHILE:
-       case OP_GREPWHILE:
-       case OP_AND:
+        case OP_AND:
        case OP_OR:
        case OP_DOR:
+            fop = cLOGOP->op_first;
+            sop = fop->op_sibling;
+           while (cLOGOP->op_other->op_type == OP_NULL)
+               cLOGOP->op_other = cLOGOP->op_other->op_next;
+           peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+          
+          stitch_keys:     
+           o->op_opt = 1;
+            if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+                || ( sop && 
+                     (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
+                    )
+            ){ 
+                OP * nop = o;
+                OP * lop = o;
+                if (!(nop->op_flags && OPf_WANT_VOID)) {
+                    while (nop && nop->op_next) {
+                        switch (nop->op_next->op_type) {
+                            case OP_NOT:
+                            case OP_AND:
+                            case OP_OR:
+                            case OP_DOR:
+                                lop = nop = nop->op_next;
+                                break;
+                            case OP_NULL:
+                                nop = nop->op_next;
+                                break;
+                            default:
+                                nop = NULL;
+                                break;
+                        }
+                    }            
+                }
+                if (lop->op_flags && OPf_WANT_VOID) {
+                    if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) 
+                        cLOGOP->op_first = opt_scalarhv(fop);
+                    if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) 
+                        cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
+                }                                        
+            }                  
+            
+           
+           break;
+       }    
+       
+       case OP_MAPWHILE:
+       case OP_GREPWHILE:
        case OP_ANDASSIGN:
        case OP_ORASSIGN:
        case OP_DORASSIGN:

diff --git a/opcode.h b/opcode.h
index aa57e21..7bacf19 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -398,6 +398,7 @@ EXTCONST char* const PL_op_name[] = {
        "lock",
        "once",
        "custom",
+       "boolkeys",
 };
 #endif
 
@@ -770,6 +771,7 @@ EXTCONST char* const PL_op_desc[] = {
        "lock",
        "once",
        "unknown custom operator",
+       "boolkeys",
 };
 #endif
 
@@ -1156,6 +1158,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
        MEMBER_TO_FPTR(Perl_pp_lock),
        MEMBER_TO_FPTR(Perl_pp_once),
        MEMBER_TO_FPTR(Perl_unimplemented_op),  /* Perl_pp_custom */
+       MEMBER_TO_FPTR(Perl_pp_boolkeys),
 }
 #endif
 #ifdef PERL_PPADDR_INITED
@@ -1539,6 +1542,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        MEMBER_TO_FPTR(Perl_ck_rfun),   /* lock */
        MEMBER_TO_FPTR(Perl_ck_null),   /* once */
        MEMBER_TO_FPTR(Perl_ck_null),   /* custom */
+       MEMBER_TO_FPTR(Perl_ck_fun),    /* boolkeys */
 }
 #endif
 #ifdef PERL_CHECK_INITED
@@ -1916,6 +1920,7 @@ EXTCONST U32 PL_opargs[] = {
        0x0000f604,     /* lock */
        0x00000600,     /* once */
        0x00000000,     /* custom */
+       0x00009600,     /* boolkeys */
 };
 #endif
 

diff --git a/opcode.pl b/opcode.pl
index 2cc242f..2de2bf4 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -1116,3 +1116,5 @@ lock              lock                    ck_rfun         s%      R
 once           once                    ck_null         |       
 
 custom         unknown custom operator         ck_null         0
+
+boolkeys       boolkeys                ck_fun          %       H

diff --git a/opnames.h b/opnames.h
index 3914ea8..f719633 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -380,10 +380,11 @@ typedef enum opcode {
        OP_LOCK          = 362,
        OP_ONCE          = 363,
        OP_CUSTOM        = 364,
+       OP_BOOLKEYS      = 365,
        OP_max          
 } opcode;
 
-#define MAXO 365
+#define MAXO 366
 #define OP_phoney_INPUT_ONLY -1
 #define OP_phoney_OUTPUT_ONLY -2
 

diff --git a/pp.c b/pp.c
index d720b70..078db3b 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5325,6 +5325,24 @@ PP(unimplemented_op)
        PL_op->op_type);
 }
 
+PP(pp_boolkeys)
+{
+    dVAR;
+    dSP;
+    HV * const hv = (HV*)POPs;
+    
+    if (SvRMAGICAL(hv)) {
+       MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
+       if (mg) {
+            XPUSHs(magic_scalarpack(hv, mg));
+           RETURN;
+        }          
+    }
+
+    XPUSHs(boolSV(HvKEYS(hv) != 0));
+    RETURN;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd

diff --git a/pp.sym b/pp.sym
index 9a2a6b2..d6eb7f5 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -408,5 +408,6 @@ Perl_pp_getlogin
 Perl_pp_syscall
 Perl_pp_lock
 Perl_pp_once
+Perl_pp_boolkeys
 
 # ex: set ro:

diff --git a/pp_proto.h b/pp_proto.h
index 0c1829a..16c5c8c 100644 (file)
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -409,5 +409,6 @@ PERL_PPDEF(Perl_pp_getlogin)
 PERL_PPDEF(Perl_pp_syscall)
 PERL_PPDEF(Perl_pp_lock)
 PERL_PPDEF(Perl_pp_once)
+PERL_PPDEF(Perl_pp_boolkeys)
 
 /* ex: set ro: */

diff --git a/proto.h b/proto.h
index db9093d..186bf40 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1400,6 +1400,13 @@ PERL_CALLCONV I32        Perl_keyword(pTHX_ const char *name, I32 len, bool all_keyword
 #define PERL_ARGS_ASSERT_KEYWORD       \
        assert(name)
 
+#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
+STATIC OP*     S_opt_scalarhv(pTHX_ OP* rep_op)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPT_SCALARHV  \
+       assert(rep_op)
+
+#endif
 PERL_CALLCONV void     Perl_leave_scope(pTHX_ I32 base);
 PERL_CALLCONV void     Perl_lex_end(pTHX);
 PERL_CALLCONV void     Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp, bool new_filter);

diff --git a/t/op/each.t b/t/op/each.t
index b88f1ea..02438f2 100644 (file)
--- a/t/op/each.t
+++ b/t/op/each.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 42;
+plan tests => 52;
 
 $h{'abc'} = 'ABC';
 $h{'def'} = 'DEF';
@@ -193,3 +193,38 @@ for my $k (qw(each keys values)) {
     eval $k;
     like($@, qr/^Not enough arguments for $k/, "$k demands argument");
 }
+
+{
+    my %foo=(1..10);
+    my ($k,$v);
+    my $count=keys %foo;
+    my ($k1,$v1)=each(%foo);
+    my $yes = 0;
+    if (%foo) { $yes++ }
+    my ($k2,$v2)=each(%foo);
+    my $rest=0;
+    while (each(%foo)) {$rest++};
+    is($yes,1,"if(%foo) was true");
+    isnt($k1,$k2,"if(%foo) didnt mess with each (key)");
+    isnt($v1,$v2,"if(%foo) didnt mess with each (value)");
+    is($rest,3,"Got the expect number of keys");
+    my $hsv=1 && %foo;
+    like($hsv,'/',"Got bucket stats from %foo in scalar assignment context");
+}    
+{
+    our %foo=(1..10);
+    my ($k,$v);
+    my $count=keys %foo;
+    my ($k1,$v1)=each(%foo);
+    my $yes = 0;
+    if (%foo) { $yes++ }
+    my ($k2,$v2)=each(%foo);
+    my $rest=0;
+    while (each(%foo)) {$rest++};
+    is($yes,1,"if(%foo) was true");
+    isnt($k1,$k2,"if(%foo) didnt mess with each (key)");
+    isnt($v1,$v2,"if(%foo) didnt mess with each (value)");
+    is($rest,3,"Got the expect number of keys");
+    my $hsv=1 && %foo;
+    like($hsv,'/',"Got bucket stats from %foo in scalar assignment context");
+}    

diff --git a/t/op/tie.t b/t/op/tie.t
index 51c8484..8298ed2 100644 (file)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -506,13 +506,17 @@ package main;
 tie my %h => "TieScalar";
 $h{key1} = "val1";
 $h{key2} = "val2";
-print scalar %h, "\n";
+print scalar %h, "\n"
+    if %h; # this should also call SCALAR but implicitly
 %h = ();
-print scalar %h, "\n";
+print scalar %h, "\n"
+    if !%h; # this should also call SCALAR but implicitly
 EXPECT
 SCALAR
+SCALAR
 2/2
 SCALAR
+SCALAR
 0
 ########