[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
Re: [ID 19991223.005] simple optimiser bug in perl-5.005_63, sample
On Fri, 24 Dec 1999 18:20:59 EST, Ilya Zakharevich wrote:
>Cameron Simpson writes:
>> The following code prints "H H ". It should print "H 1234-5678".
>>
>> #!/usr/bin/perl
>> my $home='1234-5678';
>> $home="H ".(ref $home ? "@$home" : $home);
>> print "$home\n";
>
>This shows that compile-time checks for "dangerous ops" (those which
>behave "wrong" if target coincides with one of the args) are not enough.
>
>Here OP_CONCAT has a target which may coincide with the right
>argument, but it is pretty hopeless to detect this at compile time
>(one needs a list of OPs which may return a random lexical variable).
>
>The fix for CONCAT happens to be simple: a check at run-time may
>actually *speed* things up. What remains is to decide what to do with
>two other "dangerous" ops: OP_JOIN and OP_QUOTEMETA. My guts say that
I've decided to disable the optimization for those two. Let me know
if/when someone figures out a _correct_ way to do it.
>optimization of OP_JOIN is pretty important, and it would be a pity to
>lose it...
>
>Ilya
>
>P.S. Can somebody with good memory of OOK-hack vgrep the last chunk
> wrt possible optimizations?
[...]
>+ sv_precatpvn(TARG, s1, l);
>+ goto done;
[...]
> 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);
>+}
sv_insert() was meant to do what you're doing above, so why not use
that?
Sarathy
gsar@ActiveState.com
-----------------------------------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.
- Follow-Ups from:
-
Ilya Zakharevich <ilya@math.ohio-state.edu>
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]