simple optimiser bug in perl-5.005_63, sample included #988
Comments
From cameron@research.canon.com.auThe following code prints "H H ". It should print "H 1234-5678". #!/usr/bin/perl It behaves correctly if $home is not a "my" variable. Perl Info |
From [Unknown Contact. See original ticket]Cameron Simpson writes:
Uh-oh! OP_CONCAT with lex_assign optimization. I thought this was Ilya |
From [Unknown Contact. See original ticket]Cameron Simpson writes:
This shows that compile-time checks for "dangerous ops" (those which Here OP_CONCAT has a target which may coincide with the right The fix for CONCAT happens to be simple: a check at run-time may Ilya P.S. Can somebody with good memory of OOK-hack vgrep the last chunk Inline Patch--- ./pp_hot.c-pre Fri Dec 24 17:08:09 1999
+++ ./pp_hot.c Fri Dec 24 17:59:24 1999
@@ -153,9 +153,17 @@ PP(pp_concat)
dPOPTOPssrl;
STRLEN len;
char *s;
+
if (TARG != left) {
- s = SvPV(left,len);
- sv_setpvn(TARG,s,len);
+ STRLEN l;
+ char *s1 = SvPV(left,l);
+
+ if (TARG == right) { /* Should be rare, most cases
+ eliminated by ck_concat */
+ sv_precatpvn(TARG, s1, l);
+ goto done;
+ }
+ sv_setpvn(TARG,s1,l);
}
else if (SvGMAGICAL(TARG))
mg_get(TARG);
@@ -181,6 +189,7 @@ PP(pp_concat)
}
else
sv_setpvn(TARG,s,len); /* suppress warning */
+ done:
SETTARG;
RETURN;
}
--- ./t/op/lex_assign.t~ Sun Oct 24 07:51:32 1999
+++ ./t/op/lex_assign.t Fri Dec 24 16:42:35 1999
@@ -24,7 +24,7 @@ sub subb {"in s"}
@INPUT = <DATA>;
@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
-print "1..", (8 + @INPUT + @simple_input), "\n";
+print "1..", (9 + @INPUT + @simple_input), "\n";
$ord = 0;
sub wrn {"@_"}
@@ -51,6 +51,12 @@ $b = $a+5;
$ord++;
print "not " unless $dc == 1;
+print "ok $ord\n";
+
+$ord++;
+my $xxx = 'b';
+$xxx = 'c' . ($xxx || 'e');
+print "not " unless $xxx eq 'cb';
print "ok $ord\n";
{ # Check calling STORE
--- ./op.c~ Thu Dec 9 04:17:01 1999
+++ ./op.c Fri Dec 24 17:44:49 1999
@@ -5593,13 +5593,7 @@ Perl_ck_sassign(pTHX_ OP *o)
if (kkid && kkid->op_type == OP_PADSV
&& !(kkid->op_private & OPpLVAL_INTRO))
{
- /* Concat has problems if target is equal to right arg. */
- if (kid->op_type == OP_CONCAT) {
- if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV
- && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
- return o;
- }
- else if (kid->op_type == OP_JOIN) {
+ if (kid->op_type == OP_JOIN) {
/* do_join has problems if the arguments coincide with target.
In fact the second argument *can* safely coincide,
but ignore=pessimize this rare occasion. */
--- ./embed.pl~ Thu Dec 9 02:40:50 1999
+++ ./embed.pl Fri Dec 24 17:59:09 1999
@@ -1698,6 +1698,7 @@ p |char* |sv_peek |SV* sv
p |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp
p |void |sv_pos_b2u |SV* sv|I32* offsetp
p |char* |sv_pvn_force |SV* sv|STRLEN* lp
+p |void |sv_precatpvn |SV* sv|const char* ptr|STRLEN len
p |char* |sv_reftype |SV* sv|int ob
p |void |sv_replace |SV* sv|SV* nsv
p |void |sv_report_used
--- ./sv.c~ Thu Dec 9 04:07:22 1999
+++ ./sv.c Fri Dec 24 17:55:12 1999
@@ -2850,6 +2850,24 @@ Perl_sv_catpvn(pTHX_ register SV *sv, re
}
void
+Perl_sv_precatpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+{
+ STRLEN tlen;
+ char *junk;
+
+ junk = SvPV_force(sv, tlen);
+ SvGROW(sv, tlen + len + 1);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
+ Move(SvPVX(sv),SvPVX(sv)+len,tlen,char);
+ Move(ptr,SvPVX(sv),len,char);
+ SvCUR(sv) += len;
+ *SvEND(sv) = '\0';
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
sv_catpvn(sv,ptr,len); |
From @gsarOn Fri, 24 Dec 1999 18:20:59 EST, Ilya Zakharevich wrote:
I've decided to disable the optimization for those two. Let me know
sv_insert() was meant to do what you're doing above, so why not use Sarathy Inline Patch-----------------------------------8<-----------------------------------
Change 4749 by gsar@auger on 2000/01/02 21:37:29
disable optimization in change#3612 for join() and quotemeta()--this
removes all the gross hacks for the special cases in that change; fix
pp_concat() for when TARG == arg (modified version of patch suggested
by Ilya Zakharevich)
Affected files ...
... //depot/perl/op.c#230 edit
... //depot/perl/opcode.h#57 edit
... //depot/perl/opcode.pl#61 edit
... //depot/perl/pp_hot.c#152 edit
... //depot/perl/sv.c#183 edit
... //depot/perl/t/op/lex_assign.t#11 edit
Differences ...
==== //depot/perl/op.c#230 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Sun Jan 2 13:37:33 2000
+++ perl/op.c Sun Jan 2 13:37:33 2000
@@ -5593,31 +5593,6 @@
if (kkid && kkid->op_type == OP_PADSV
&& !(kkid->op_private & OPpLVAL_INTRO))
{
- /* Concat has problems if target is equal to right arg. */
- if (kid->op_type == OP_CONCAT) {
- if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV
- && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
- return o;
- }
- else if (kid->op_type == OP_JOIN) {
- /* do_join has problems if the arguments coincide with target.
- In fact the second argument *can* safely coincide,
- but ignore=pessimize this rare occasion. */
- OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */
-
- while (arg) {
- if (arg->op_type == OP_PADSV
- && arg->op_targ == kkid->op_targ)
- return o;
- arg = arg->op_sibling;
- }
- }
- else if (kid->op_type == OP_QUOTEMETA) {
- /* quotemeta has problems if the argument coincides with target. */
- if (kLISTOP->op_first->op_type == OP_PADSV
- && kLISTOP->op_first->op_targ == kkid->op_targ)
- return o;
- }
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN. */
@@ -6201,26 +6176,13 @@
case OP_UCFIRST:
case OP_LC:
case OP_LCFIRST:
- if ( o->op_next && o->op_next->op_type == OP_STRINGIFY
- && !(o->op_next->op_private & OPpTARGET_MY) )
- null(o->op_next);
- o->op_seq = PL_op_seqmax++;
- break;
case OP_CONCAT:
case OP_JOIN:
case OP_QUOTEMETA:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
- if ((o->op_flags & OPf_STACKED) /* chained concats */
- || (o->op_type == OP_CONCAT
- /* Concat has problems if target is equal to right arg. */
- && (((LISTOP*)o)->op_first->op_sibling->op_type
- == OP_PADSV)
- && (((LISTOP*)o)->op_first->op_sibling->op_targ
- == o->op_next->op_targ)))
- {
+ if (o->op_flags & OPf_STACKED) /* chained concats */
goto ignore_optimization;
- }
else {
o->op_targ = o->op_next->op_targ;
o->op_next->op_targ = 0;
==== //depot/perl/opcode.h#57 (text+w) ====
Index: perl/opcode.h
--- perl/opcode.h.~1~ Sun Jan 2 13:37:33 2000
+++ perl/opcode.h Sun Jan 2 13:37:33 2000
@@ -1576,7 +1576,7 @@
0x0001368e, /* lcfirst */
0x0001368e, /* uc */
0x0001368e, /* lc */
- 0x0001378e, /* quotemeta */
+ 0x0001368e, /* quotemeta */
0x00000248, /* rv2av */
0x00026c04, /* aelemfast */
0x00026404, /* aelem */
@@ -1592,7 +1592,7 @@
0x00022800, /* unpack */
0x0004280d, /* pack */
0x00222808, /* split */
- 0x0004290d, /* join */
+ 0x0004280d, /* join */
0x00004801, /* list */
0x00448400, /* lslice */
0x00004805, /* anonlist */
==== //depot/perl/opcode.pl#61 (xtext) ====
Index: perl/opcode.pl
--- perl/opcode.pl.~1~ Sun Jan 2 13:37:33 2000
+++ perl/opcode.pl Sun Jan 2 13:37:33 2000
@@ -298,6 +298,7 @@
# ref not OK (RETPUSHNO)
# trans not OK (dTARG; TARG = sv_newmortal();)
# ucfirst etc not OK: TMP arg processed inplace
+# quotemeta not OK (unsafe when TARG == arg)
# each repeat not OK too due to array context
# pack split - unknown whether they are safe
# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
@@ -314,6 +315,7 @@
# readline - unknown whether it is safe
# match subst not OK (dTARG)
# grepwhile not OK (not always setting)
+# join not OK (unsafe when TARG == arg)
# Suspicious wrt "additional mode of failure": concat (dealt with
# in ck_sassign()), join (same).
@@ -506,7 +508,7 @@
lcfirst lcfirst ck_fun_locale fstu% S?
uc uc ck_fun_locale fstu% S?
lc lc ck_fun_locale fstu% S?
-quotemeta quotemeta ck_fun fsTu% S?
+quotemeta quotemeta ck_fun fstu% S?
# Arrays.
@@ -531,7 +533,7 @@
unpack unpack ck_fun @ S S
pack pack ck_fun mst@ S L
split split ck_split t@ S S S
-join join ck_join msT@ S L
+join join ck_join mst@ S L
# List operators.
==== //depot/perl/pp_hot.c#152 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c.~1~ Sun Jan 2 13:37:33 2000
+++ perl/pp_hot.c Sun Jan 2 13:37:33 2000
@@ -152,8 +152,14 @@
dPOPTOPssrl;
STRLEN len;
char *s;
+
if (TARG != left) {
s = SvPV(left,len);
+ if (TARG == right) {
+ sv_insert(TARG, 0, 0, s, len);
+ SETs(TARG);
+ RETURN;
+ }
sv_setpvn(TARG,s,len);
}
else if (SvGMAGICAL(TARG))
==== //depot/perl/sv.c#183 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~ Sun Jan 2 13:37:33 2000
+++ perl/sv.c Sun Jan 2 13:37:33 2000
@@ -3210,6 +3210,7 @@
SvCUR_set(bigstr, offset+len);
}
+ SvTAINT(bigstr);
i = littlelen - len;
if (i > 0) { /* string might grow */
big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
==== //depot/perl/t/op/lex_assign.t#11 (xtext) ====
Index: perl/t/op/lex_assign.t
--- perl/t/op/lex_assign.t.~1~ Sun Jan 2 13:37:33 2000
+++ perl/t/op/lex_assign.t Sun Jan 2 13:37:33 2000
@@ -24,7 +24,7 @@
@INPUT = <DATA>;
@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
-print "1..", (8 + @INPUT + @simple_input), "\n";
+print "1..", (9 + @INPUT + @simple_input), "\n";
$ord = 0;
sub wrn {"@_"}
@@ -53,6 +53,12 @@
print "not " unless $dc == 1;
print "ok $ord\n";
+$ord++;
+my $xxx = 'b';
+$xxx = 'c' . ($xxx || 'e');
+print "not " unless $xxx eq 'cb';
+print "ok $ord\n";
+
{ # Check calling STORE
my $sc = 0;
sub B::TIESCALAR {bless [11], 'B'}
End of Patch. |
From [Unknown Contact. See original ticket]On Wed, Jan 05, 2000 at 10:58:17AM -0800, Gurusamy Sarathy wrote:
I will.
Ignorance. Additionally, this gives a shorter path through the forest Ilya |
Migrated from rt.perl.org#1937 (status was 'resolved')
Searchable as RT1937$
The text was updated successfully, but these errors were encountered: