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.
Perl · Oct 15, 2009 · 867fa1e · 867fa1e
1 parent 1c85afc
commit 867fa1e
Show file tree

Hide file tree

Showing 14 changed files with 181 additions and 9 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -1116,3 +1116,5 @@ sub tab {
 once		once			ck_null		|	
 
 custom		unknown custom operator		ck_null		0
+
+boolkeys	boolkeys		ck_fun		%	H
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
 ########