develooper Front page | perl.perl5.porters | Postings from March 2000

[PATCH 5.5.670] pseudohash, one more try

Thread Previous | Thread Next
From:
John Tobey
Date:
March 2, 2000 02:31
Subject:
[PATCH 5.5.670] pseudohash, one more try
Message ID:
m12QStM-000FSsC@feynman.localnet
Gurusamy Sarathy <gsar@ActiveState.com> wrote:
> On Mon, 28 Feb 2000 22:13:31 EST, John Tobey wrote:
> >Here is a new version of the patch that avoids op.c and instead walks
> >the op tree at run time in pp_aassign.
> 
> In general, walking the optree at run time is less desirable than
> compile time recognition.  I think your previous approach with
> ck_aassign() was better.

Okay.  I've put the compile-time check back in, this time in
Perl_newASSIGNOP.  pp_aassign walks the op tree when an AV/AVHV is
found and the op flag indicates a % expression exists somewhere on the
left side.  Simple hash variables (%foo) are discounted because they
cannot be pseudohashes.  I believe that false positives (op tree
walked but no avhv) would be rare.

I mentioned benchmarks that showed an earlier version of this patch to
be up to 10% slower on list assignments.  Subsequent testing indicates
that 10% is within the range of random noise for my benchmark.  For
example, this patch, applied to 5.5.660, actually *improves*
performance by 10% in one of my cases and by 3% even in the case that
requires op-walking.  But patching 5.5.670 with it results in a 5%
slowdown.  (All tests used gcc -O2 and did a million assignments to
lists.  The randomness is per-build, not per run of the benchmark.)  I
conclude that it will have different effects on different machines and
releases, so it does not concern us.

I've split two pieces of pp_aassign out into static functions.  This
was part of an experiment to see if moving less-frequently executed
code out of the middle would trigger some CPU or paging magic that
would improve performance.  I might try merging the functions back
into pp_aassign if I had the tuits.

Thanks
-John

-- 
John Tobey, late nite hacker <jtobey@john-edwin-tobey.org>
\\\                                                               ///
]]]             With enough bugs, all eyes are shallow.           [[[
///                                                               \\\


diff -ur perl-5.5.670/av.c perl-5.5.670.john/av.c
--- perl-5.5.670/av.c	Sat Feb 26 02:45:37 2000
+++ perl-5.5.670.john/av.c	Thu Mar  2 03:56:47 2000
@@ -805,6 +805,20 @@
     return index;    
 }
 
+STATIC I32
+S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+    HV *keys;
+    HE *he;
+    STRLEN n_a;
+
+    keys = avhv_keys(av);
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he)
+        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
+    return avhv_index_sv(HeVAL(he));
+}
+
 HV*
 Perl_avhv_keys(pTHX_ AV *av)
 {
@@ -824,17 +838,15 @@
 }
 
 SV**
+Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
+{
+    return av_store(av, avhv_index(av, keysv, hash), val);
+}
+
+SV**
 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 {
-    SV **indsvp;
-    HV *keys = avhv_keys(av);
-    HE *he;
-    STRLEN n_a;
-   
-    he = hv_fetch_ent(keys, keysv, FALSE, hash);
-    if (!he)
-        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
-    return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+    return av_fetch(av, avhv_index(av, keysv, hash), lval);
 }
 
 SV *
diff -ur perl-5.5.670/dump.c perl-5.5.670.john/dump.c
--- perl-5.5.670/dump.c	Thu Feb 17 12:48:49 2000
+++ perl-5.5.670.john/dump.c	Thu Mar  2 05:02:08 2000
@@ -433,6 +433,8 @@
 	if (o->op_type == OP_AASSIGN) {
 	    if (o->op_private & OPpASSIGN_COMMON)
 		sv_catpv(tmpsv, ",COMMON");
+	    if (o->op_private & OPpASSIGN_HASH)
+		sv_catpv(tmpsv, ",HASH");
 	}
 	else if (o->op_type == OP_SASSIGN) {
 	    if (o->op_private & OPpASSIGN_BACKWARDS)
diff -ur perl-5.5.670/embed.pl perl-5.5.670.john/embed.pl
--- perl-5.5.670/embed.pl	Mon Feb 28 23:15:15 2000
+++ perl-5.5.670.john/embed.pl	Thu Mar  2 03:56:47 2000
@@ -1354,6 +1354,7 @@
 Ap	|SV*	|avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
 Ap	|bool	|avhv_exists_ent|AV *ar|SV* keysv|U32 hash
 Ap	|SV**	|avhv_fetch_ent	|AV *ar|SV* keysv|I32 lval|U32 hash
+Ap	|SV**	|avhv_store_ent	|AV *ar|SV* keysv|SV* val|U32 hash
 Ap	|HE*	|avhv_iternext	|AV *ar
 Ap	|SV*	|avhv_iterval	|AV *ar|HE* entry
 Ap	|HV*	|avhv_keys	|AV *ar
@@ -2156,6 +2157,7 @@
 
 #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
 s	|I32	|avhv_index_sv	|SV* sv
+s	|I32	|avhv_index	|AV* av|SV* sv|U32 hash
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
@@ -2287,6 +2289,9 @@
 #endif
 
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
+s	|int	|do_maybe_phash	|AV *ary|SV **lelem|SV **firstlelem \
+				|SV **relem|SV **lastrelem
+s	|void	|do_oddball	|HV *hash|SV **relem|SV **firstrelem
 s	|CV*	|get_db_sub	|SV **svp|CV *cv
 s	|SV*	|method_common	|SV* meth|U32* hashp
 #endif
diff -ur perl-5.5.670/op.c perl-5.5.670.john/op.c
--- perl-5.5.670/op.c	Sun Feb 27 09:28:52 2000
+++ perl-5.5.670.john/op.c	Thu Mar  2 05:26:52 2000
@@ -3273,6 +3273,8 @@
 
     if (list_assignment(left)) {
 	dTHR;
+	OP *curop;
+
 	PL_modcount = 0;
 	PL_eval_start = right;	/* Grandfathering $[ assignment here.  Bletch.*/
 	left = mod(left, OP_AASSIGN);
@@ -3283,12 +3285,18 @@
 	    op_free(right);
 	    return Nullop;
 	}
-	o = newBINOP(OP_AASSIGN, flags,
-		list(force_list(right)),
-		list(force_list(left)) );
+	curop = list(force_list(left));
+	o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
 	o->op_private = 0 | (flags >> 8);
+	for (curop = ((LISTOP*)curop)->op_first;
+	     curop; curop = curop->op_sibling) {
+	    if (curop->op_type == OP_RV2HV &&
+		((UNOP*)curop)->op_first->op_type != OP_GV) {
+		o->op_private |= OPpASSIGN_HASH;
+		break;
+	    }
+	}
 	if (!(left->op_private & OPpLVAL_INTRO)) {
-	    OP *curop;
 	    OP *lastop = o;
 	    PL_generation++;
 	    for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -3332,7 +3340,7 @@
 		lastop = curop;
 	    }
 	    if (curop != o)
-		o->op_private = OPpASSIGN_COMMON;
+		o->op_private |= OPpASSIGN_COMMON;
 	}
 	if (right && right->op_type == OP_SPLIT) {
 	    OP* tmpop;
diff -ur perl-5.5.670/op.h perl-5.5.670.john/op.h
--- perl-5.5.670/op.h	Fri Feb 25 13:56:46 2000
+++ perl-5.5.670.john/op.h	Thu Mar  2 03:56:47 2000
@@ -118,6 +118,7 @@
 
 /* Private for OP_AASSIGN */
 #define OPpASSIGN_COMMON	64	/* Left & right have syms in common. */
+#define OPpASSIGN_HASH		32	/* Assigning to possible pseudohash. */
 
 /* Private for OP_SASSIGN */
 #define OPpASSIGN_BACKWARDS	64	/* Left & right switched. */
diff -ur perl-5.5.670/pp_hot.c perl-5.5.670.john/pp_hot.c
--- perl-5.5.670/pp_hot.c	Sat Feb 26 13:12:51 2000
+++ perl-5.5.670.john/pp_hot.c	Thu Mar  2 03:56:47 2000
@@ -621,6 +621,89 @@
     }
 }
 
+STATIC int
+S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
+		 SV **lastrelem)
+{
+    OP *leftop;
+    SV *tmpstr;
+    I32 i;
+
+    leftop = ((BINOP*)PL_op)->op_last;
+    assert(leftop);
+    assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
+    leftop = ((LISTOP*)leftop)->op_first;
+    assert(leftop);
+    /* Skip PUSHMARK and each element already assigned to. */
+    for (i = lelem - firstlelem; i > 0; i--) {
+	leftop = leftop->op_sibling;
+	assert(leftop);
+    }
+    if (leftop->op_type != OP_RV2HV)
+	return 0;
+
+		/* pseudohash */
+    if (av_len(ary) > 0)
+	av_fill(ary, 0);	/* clear all but the fields hash */
+    if (lastrelem >= relem) {
+	while (relem < lastrelem) {	/* gobble up all the rest */
+	    SV *tmpstr;
+	    assert(relem[0]);
+	    assert(relem[1]);
+	    /* Avoid a memory leak when avhv_store_ent dies. */
+	    tmpstr = sv_newmortal();
+	    sv_setsv(tmpstr,relem[1]);	/* value */
+	    relem[1] = tmpstr;
+	    if (avhv_store_ent(ary,relem[0],tmpstr,0))
+		SvREFCNT_inc(tmpstr);
+	    if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
+		mg_set(tmpstr);
+	    relem += 2;
+	    TAINT_NOT;
+	}
+    }
+    if (relem == lastrelem)
+	return 1;
+    return 2;
+}
+
+STATIC void
+S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+{
+    if (*relem) {
+	SV *tmpstr;
+	if (ckWARN(WARN_MISC)) {
+	    if (relem == firstrelem &&
+		SvROK(*relem) &&
+		( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
+		  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
+		Perl_warner(aTHX_ WARN_MISC, "Reference found where even-sized list expected");
+	    else
+		Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+	}
+	if (SvTYPE(hash) == SVt_PVAV) {
+	    /* pseudohash */
+	    tmpstr = sv_newmortal();
+	    if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
+		SvREFCNT_inc(tmpstr);
+	    if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
+		mg_set(tmpstr);
+	}
+	else {
+	    HE *didstore;
+	    tmpstr = NEWSV(29,0);
+	    didstore = hv_store_ent(hash,*relem,tmpstr,0);
+	    if (SvMAGICAL(hash)) {
+		if (SvSMAGICAL(tmpstr))
+		    mg_set(tmpstr);
+		if (!didstore)
+		    sv_2mortal(tmpstr);
+	    }
+	}
+	TAINT_NOT;
+    }
+}
+
 PP(pp_aassign)
 {
     djSP;
@@ -646,21 +729,22 @@
      * special care that assigning the identifier on the left doesn't
      * clobber a value on the right that's used later in the list.
      */
-    if (PL_op->op_private & OPpASSIGN_COMMON) {
+    if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 	EXTEND_MORTAL(lastrelem - firstrelem + 1);
-        for (relem = firstrelem; relem <= lastrelem; relem++) {
-            /*SUPPRESS 560*/
-            if (sv = *relem) {
+	for (relem = firstrelem; relem <= lastrelem; relem++) {
+	    /*SUPPRESS 560*/
+	    if (sv = *relem) {
 		TAINT_NOT;	/* Each item is independent */
-                *relem = sv_mortalcopy(sv);
+		*relem = sv_mortalcopy(sv);
 	    }
-        }
+	}
     }
 
     relem = firstrelem;
     lelem = firstlelem;
     ary = Null(AV*);
     hash = Null(HV*);
+
     while (lelem <= lastlelem) {
 	TAINT_NOT;		/* Each item stands on its own, taintwise. */
 	sv = *lelem++;
@@ -668,7 +752,19 @@
 	case SVt_PVAV:
 	    ary = (AV*)sv;
 	    magic = SvMAGICAL(ary) != 0;
-	    
+	    if (PL_op->op_private & OPpASSIGN_HASH) {
+		switch (do_maybe_phash(ary, lelem, firstlelem, relem,
+				       lastrelem))
+		{
+		case 0:
+		    goto normal_array;
+		case 1:
+		    do_oddball((HV*)ary, relem, firstrelem);
+		}
+		relem = lastrelem + 1;
+		break;
+	    }
+	normal_array:
 	    av_clear(ary);
 	    av_extend(ary, lastrelem - relem);
 	    i = 0;
@@ -688,7 +784,7 @@
 		TAINT_NOT;
 	    }
 	    break;
-	case SVt_PVHV: {
+	case SVt_PVHV: {				/* normal hash */
 		SV *tmpstr;
 
 		hash = (HV*)sv;
@@ -715,27 +811,7 @@
 		    TAINT_NOT;
 		}
 		if (relem == lastrelem) {
-		    if (*relem) {
-			HE *didstore;
-			if (ckWARN(WARN_MISC)) {
-			    if (relem == firstrelem &&
-				SvROK(*relem) &&
-				( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
-				  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
-				Perl_warner(aTHX_ WARN_MISC, "Reference found where even-sized list expected");
-			    else
-				Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
-			}
-			tmpstr = NEWSV(29,0);
-			didstore = hv_store_ent(hash,*relem,tmpstr,0);
-			if (magic) {
-			    if (SvSMAGICAL(tmpstr))
-				mg_set(tmpstr);
-			    if (!didstore)
-				sv_2mortal(tmpstr);
-			}
-			TAINT_NOT;
-		    }
+		    do_oddball(hash, relem, firstrelem);
 		    relem++;
 		}
 	    }
diff -ur perl-5.5.670/t/op/avhv.t perl-5.5.670.john/t/op/avhv.t
--- perl-5.5.670/t/op/avhv.t	Thu Jan 13 01:42:53 2000
+++ perl-5.5.670.john/t/op/avhv.t	Thu Mar  2 05:28:52 2000
@@ -1,5 +1,5 @@
 #!./perl
-      
+
 BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
@@ -17,7 +17,7 @@
 
 package main;
 
-print "1..20\n";
+print "1..28\n";
 
 $sch = {
     'abc' => 1,
@@ -139,3 +139,40 @@
 
 print "not " unless "$avhv->{bar}" eq "yyy";
 print "ok 20\n";
+
+# hash assignment
+%$avhv = ();
+print "not " unless ref($avhv->[0]) eq 'HASH';
+print "ok 21\n";
+
+%hv = %$avhv;
+print "not " if grep defined, values %hv;
+print "ok 22\n";
+print "not " if grep ref, keys %hv;
+print "ok 23\n";
+
+%$avhv = (foo => 29, pants => 2, bar => 0);
+print "not " unless "@$avhv[1..3]" eq '29 0 2';
+print "ok 24\n";
+
+my $extra;
+my @extra;
+($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo';
+print "ok 25\n";
+
+%$avhv = ();
+(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra;
+print "ok 26\n";
+
+@extra = qw(whatever and stuff);
+%$avhv = ();
+(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0;
+print "ok 27\n";
+
+%$avhv = ();
+(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
+print "ok 28\n";
diff -ur perl-5.5.670/t/op/hashwarn.t perl-5.5.670.john/t/op/hashwarn.t
--- perl-5.5.670/t/op/hashwarn.t	Tue Jul 20 13:18:14 1999
+++ perl-5.5.670.john/t/op/hashwarn.t	Thu Mar  2 03:56:47 2000
@@ -14,7 +14,7 @@
     # ...and save 'em as we go
     $SIG{'__WARN__'} = sub { push @warnings, @_ };
     $| = 1;
-    print "1..7\n";
+    print "1..9\n";
 }
 
 END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings }
@@ -66,6 +66,13 @@
     %hash = sub { print "ok" };
     test_warning 6, shift @warnings, $odd_msg;
 
+    my $avhv = [{x=>1,y=>2}];
+    %$avhv = (x=>13,'y');
+    test_warning 7, shift @warnings, $odd_msg;
+
+    %$avhv = 'x';
+    test_warning 8, shift @warnings, $odd_msg;
+
     $_ = { 1..10 };
-    test 7, ! @warnings, "Unexpected warning";
+    test 9, ! @warnings, "Unexpected warning";
 }

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About