avoid clearing @_ at all for faster subroutine calls; fix bugs

in passing around references to @_, eg C<sub foo { \@_ }>; add
tests for the same

p4raw-id: //depot/perl@4195

diff --git a/MANIFEST b/MANIFEST
index 06135b8..bb92930 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1236,6 +1236,7 @@ t/lib/timelocal.t See if Time::Local works
 t/lib/trig.t           See if Math::Trig works
 t/op/64bit.t           See if 64 bitness works
 t/op/append.t          See if . works
+t/op/args.t            See if operations on @_ work
 t/op/arith.t           See if arithmetic works
 t/op/array.t           See if array operations work
 t/op/assignwarn.t      See if OP= operators warn correctly for undef targets

diff --git a/cop.h b/cop.h
index 6ea045a..e8221b6 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -66,17 +66,22 @@ struct block_sub {
 #define POPSAVEARRAY()                                                 \
     STMT_START {                                                       \
        SvREFCNT_dec(GvAV(PL_defgv));                                   \
-       GvAV(PL_defgv) = cxsub.savearray;                                       \
+       GvAV(PL_defgv) = cxsub.savearray;                               \
     } STMT_END
 #endif /* USE_THREADS */
 
 #define POPSUB2()                                                      \
        if (cxsub.hasargs) {                                            \
            POPSAVEARRAY();                                             \
-           /* destroy arg array */                                     \
-           av_clear(cxsub.argarray);                                   \
-           AvREAL_off(cxsub.argarray);                                 \
-           AvREIFY_on(cxsub.argarray);                                 \
+           /* abandon @_ if it got reified */                          \
+           if (AvREAL(cxsub.argarray)) {                               \
+               SSize_t fill = AvFILLp(cxsub.argarray);                 \
+               SvREFCNT_dec(cxsub.argarray);                           \
+               cxsub.argarray = newAV();                               \
+               av_extend(cxsub.argarray, fill);                        \
+               AvFLAGS(cxsub.argarray) = AVf_REIFY;                    \
+               PL_curpad[0] = (SV*)cxsub.argarray;                     \
+           }                                                           \
        }                                                               \
        if (cxsub.cv) {                                                 \
            if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth))                  \

diff --git a/pp.c b/pp.c
index 07bb33d..6746aa5 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -530,6 +530,12 @@ S_refto(pTHX_ SV *sv)
        else
            (void)SvREFCNT_inc(sv);
     }
+    else if (SvTYPE(sv) == SVt_PVAV) {
+       if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
+           av_reify((AV*)sv);
+       SvTEMP_off(sv);
+       (void)SvREFCNT_inc(sv);
+    }
     else if (SvPADTMP(sv))
        sv = newSVsv(sv);
     else {

diff --git a/pp_ctl.c b/pp_ctl.c
index c9afbb6..caaaf20 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1972,7 +1972,6 @@ PP(pp_goto)
            SV** mark;
            I32 items = 0;
            I32 oldsave;
-           int arg_was_real = 0;
 
        retry:
            if (!CvROOT(cv) && !CvXSUB(cv)) {
@@ -2004,8 +2003,8 @@ PP(pp_goto)
            if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
                DIE(aTHX_ "Can't goto subroutine from an eval-string");
            mark = PL_stack_sp;
-           if (CxTYPE(cx) == CXt_SUB &&
-               cx->blk_sub.hasargs) {   /* put @_ back onto stack */
+           if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
+               /* put @_ back onto stack */
                AV* av = cx->blk_sub.argarray;
                
                items = AvFILLp(av) + 1;
@@ -2017,11 +2016,14 @@ PP(pp_goto)
                SvREFCNT_dec(GvAV(PL_defgv));
                GvAV(PL_defgv) = cx->blk_sub.savearray;
 #endif /* USE_THREADS */
+               /* abandon @_ if it got reified */
                if (AvREAL(av)) {
-                   arg_was_real = 1;
-                   AvREAL_off(av);     /* so av_clear() won't clobber elts */
+                   (void)sv_2mortal((SV*)av);  /* delay until return */
+                   av = newAV();
+                   av_extend(av, items-1);
+                   AvFLAGS(av) = AVf_REIFY;
+                   PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
                }
-               av_clear(av);
            }
            else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
                AV* av;
@@ -2179,11 +2181,7 @@ PP(pp_goto)
                    }
                    Copy(mark,AvARRAY(av),items,SV*);
                    AvFILLp(av) = items - 1;
-                   /* preserve @_ nature */
-                   if (arg_was_real) {
-                       AvREIFY_off(av);
-                       AvREAL_on(av);
-                   }
+                   assert(!AvREAL(av));
                    while (items--) {
                        if (*mark)
                            SvTEMP_off(*mark);

diff --git a/pp_hot.c b/pp_hot.c
index e75ec30..df5e062 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2522,11 +2522,7 @@ try_autoload:
                                  "%p entersub preparing @_\n", thr));
 #endif
            av = (AV*)PL_curpad[0];
-           if (AvREAL(av)) {
-               av_clear(av);
-               AvREAL_off(av);
-               AvREIFY_on(av);
-           }
+           assert(!AvREAL(av));
 #ifndef USE_THREADS
            cx->blk_sub.savearray = GvAV(PL_defgv);
            GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);

diff --git a/t/op/args.t b/t/op/args.t
new file mode 100755 (executable)
index 0000000..48bf5af
--- /dev/null
+++ b/t/op/args.t
@@ -0,0 +1,54 @@
+#!./perl
+
+print "1..8\n";
+
+# test various operations on @_
+
+my $ord = 0;
+sub new1 { bless \@_ }
+{
+    my $x = new1("x");
+    my $y = new1("y");
+    ++$ord;
+    print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y";
+    print "ok $ord\n";
+    ++$ord;
+    print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x";
+    print "ok $ord\n";
+}
+
+sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ }
+{
+    my $x = new2("x");
+    my $y = new2("y");
+    ++$ord;
+    print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x";
+    print "ok $ord\n";
+    ++$ord;
+    print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y";
+    print "ok $ord\n";
+}
+
+sub new3 { goto &new1 }
+{
+    my $x = new3("x");
+    my $y = new3("y");
+    ++$ord;
+    print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y";
+    print "ok $ord\n";
+    ++$ord;
+    print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x";
+    print "ok $ord\n";
+}
+
+sub new4 { goto &new2 }
+{
+    my $x = new4("x");
+    my $y = new4("y");
+    ++$ord;
+    print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x";
+    print "ok $ord\n";
+    ++$ord;
+    print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y";
+    print "ok $ord\n";
+}