optimize pseudohash slice in array slice at compile time (from

John Tobey <jtobey@john-edwin-tobey.org>)

p4raw-id: //depot/perl@5104

diff --git a/op.c b/op.c
index bc30f01..ea58e6f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6493,6 +6493,62 @@ Perl_peep(pTHX_ register OP *o)
            *svp = newSViv(ind);
            break;
        }
+       
+       case OP_HSLICE: {
+           UNOP *rop;
+           SV *lexname;
+           GV **fields;
+           SV **svp, **indsvp;
+           I32 ind;
+           char *key;
+           STRLEN keylen;
+           SVOP *first_key_op, *key_op;
+       
+           if ((o->op_private & (OPpLVAL_INTRO))
+               /* I bet there's always a pushmark... */
+               || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+               /* hmmm, no optimization if list contains only one key. */
+               break;
+           rop = (UNOP*)((LISTOP*)o)->op_last;
+           if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+               break;
+           lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+           if (!SvOBJECT(lexname))
+               break;
+           fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+           if (!fields || !GvHV(*fields))
+               break;
+           /* Again guessing that the pushmark can be jumped over.... */
+           first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+               ->op_first->op_sibling;
+           /* Check that the key list contains only constants. */
+           for (key_op = first_key_op; key_op;
+                key_op = (SVOP*)key_op->op_sibling)
+               if (key_op->op_type != OP_CONST)
+                   break;
+           if (key_op)
+               break;
+           rop->op_type = OP_RV2AV;
+           rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
+           o->op_type = OP_ASLICE;
+           o->op_ppaddr = PL_ppaddr[OP_ASLICE];
+           for (key_op = first_key_op; key_op;
+                key_op = (SVOP*)key_op->op_sibling) {
+               svp = cSVOPx_svp(key_op);
+               key = SvPV(*svp, keylen);
+               indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+               if (!indsvp) {
+                   Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
+                         key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
+               }
+               ind = SvIV(*indsvp);
+               if (ind < 1)
+                   Perl_croak(aTHX_ "Bad index while coercing array into hash");
+               SvREFCNT_dec(*svp);
+               *svp = newSViv(ind);
+           }
+           break;
+       }
 
        case OP_RV2AV:
        case OP_RV2HV:

diff --git a/t/lib/fields.t b/t/lib/fields.t
index 74be2c2..01f9389 100755 (executable)
--- a/t/lib/fields.t
+++ b/t/lib/fields.t
@@ -90,7 +90,7 @@ my %expect = (
     'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
 );
 
-print "1..", int(keys %expect)+5, "\n";
+print "1..", int(keys %expect)+7, "\n";
 my $testno = 0;
 while (my($class, $exp) = each %expect) {
    no strict 'refs';
@@ -117,6 +117,14 @@ eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
 print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/;
 print "ok ", ++$testno, "\n";
 
+# Slices
+@$obj1{"_b1", "b1"} = (17, 29);
+print "not " unless "@$obj1[1,2]" eq "17 29";
+print "ok ", ++$testno, "\n";
+@$obj1[1,2] = (44,28);
+print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28";
+print "ok ", ++$testno, "\n";
+
 #fields::_dump();
 
 # check if