fix deeply nested closures that have no references to lexical in

intervening subs

p4raw-id: //depot/perl@4834

diff --git a/embed.h b/embed.h
index 2d5c36b..61ffadf 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -858,6 +858,7 @@
 #define too_many_arguments     S_too_many_arguments
 #define op_clear               S_op_clear
 #define null                   S_null
+#define pad_addlex             S_pad_addlex
 #define pad_findlex            S_pad_findlex
 #define newDEFSVOP             S_newDEFSVOP
 #define new_logop              S_new_logop
@@ -2270,6 +2271,7 @@
 #define too_many_arguments(a,b)        S_too_many_arguments(aTHX_ a,b)
 #define op_clear(a)            S_op_clear(aTHX_ a)
 #define null(a)                        S_null(aTHX_ a)
+#define pad_addlex(a)          S_pad_addlex(aTHX_ a)
 #define pad_findlex(a,b,c,d,e,f,g)     S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
 #define newDEFSVOP()           S_newDEFSVOP(aTHX)
 #define new_logop(a,b,c,d)     S_new_logop(aTHX_ a,b,c,d)
@@ -4439,6 +4441,8 @@
 #define op_clear               S_op_clear
 #define S_null                 CPerlObj::S_null
 #define null                   S_null
+#define S_pad_addlex           CPerlObj::S_pad_addlex
+#define pad_addlex             S_pad_addlex
 #define S_pad_findlex          CPerlObj::S_pad_findlex
 #define pad_findlex            S_pad_findlex
 #define S_newDEFSVOP           CPerlObj::S_newDEFSVOP

diff --git a/embed.pl b/embed.pl
index 95dfed9..f235ffb 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1929,6 +1929,7 @@ s |OP*    |too_few_arguments|OP *o|char* name
 s      |OP*    |too_many_arguments|OP *o|char* name
 s      |void   |op_clear       |OP* o
 s      |void   |null           |OP* o
+s      |PADOFFSET|pad_addlex   |SV* name
 s      |PADOFFSET|pad_findlex  |char* name|PADOFFSET newoff|U32 seq \
                                |CV* startcv|I32 cx_ix|I32 saweval|U32 flags
 s      |OP*    |newDEFSVOP

diff --git a/op.c b/op.c
index 386e9de..961fe50 100644 (file)
--- a/op.c
+++ b/op.c
@@ -204,6 +204,31 @@ Perl_pad_allocmy(pTHX_ char *name)
     return off;
 }
 
+STATIC PADOFFSET
+S_pad_addlex(pTHX_ SV *proto_namesv)
+{
+    SV *namesv = NEWSV(1103,0);
+    PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
+    sv_upgrade(namesv, SVt_PVNV);
+    sv_setpv(namesv, SvPVX(proto_namesv));
+    av_store(PL_comppad_name, newoff, namesv);
+    SvNVX(namesv) = (NV)PL_curcop->cop_seq;
+    SvIVX(namesv) = PAD_MAX;                   /* A ref, intro immediately */
+    SvFAKE_on(namesv);                         /* A ref, not a real var */
+    if (SvFLAGS(proto_namesv) & SVpad_OUR) {   /* An "our" variable */
+       SvFLAGS(namesv) |= SVpad_OUR;
+       (void)SvUPGRADE(namesv, SVt_PVGV);
+       GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
+    }
+    if (SvOBJECT(proto_namesv)) {              /* A typed var */
+       SvOBJECT_on(namesv);
+       (void)SvUPGRADE(namesv, SVt_PVMG);
+       SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
+       PL_sv_objcount++;
+    }
+    return newoff;
+}
+
 #define FINDLEX_NOSEARCH       1               /* don't search outer contexts */
 
 STATIC PADOFFSET
@@ -246,28 +271,10 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
                    }
                    depth = 1;
                }
-               oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
+               oldpad = (AV*)AvARRAY(curlist)[depth];
                oldsv = *av_fetch(oldpad, off, TRUE);
                if (!newoff) {          /* Not a mere clone operation. */
-                   SV *namesv = NEWSV(1103,0);
-                   newoff = pad_alloc(OP_PADSV, SVs_PADMY);
-                   sv_upgrade(namesv, SVt_PVNV);
-                   sv_setpv(namesv, name);
-                   av_store(PL_comppad_name, newoff, namesv);
-                   SvNVX(namesv) = (NV)PL_curcop->cop_seq;
-                   SvIVX(namesv) = PAD_MAX;    /* A ref, intro immediately */
-                   SvFAKE_on(namesv);          /* A ref, not a real var */
-                   if (SvFLAGS(sv) & SVpad_OUR) { /* An "our" variable */
-                       SvFLAGS(namesv) |= SVpad_OUR;
-                       (void)SvUPGRADE(namesv, SVt_PVGV);
-                       GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(sv));
-                   }
-                   if (SvOBJECT(sv)) {         /* A typed var */
-                       SvOBJECT_on(namesv);
-                       (void)SvUPGRADE(namesv, SVt_PVMG);
-                       SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv));
-                       PL_sv_objcount++;
-                   }
+                   newoff = pad_addlex(sv);
                    if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
                        /* "It's closures all the way down." */
                        CvCLONE_on(PL_compcv);
@@ -281,8 +288,23 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
                                 bcv && bcv != cv && !CvCLONE(bcv);
                                 bcv = CvOUTSIDE(bcv))
                            {
-                               if (CvANON(bcv))
+                               if (CvANON(bcv)) {
+                                   /* install the missing pad entry in intervening
+                                    * nested subs and mark them cloneable.
+                                    * XXX fix pad_foo() to not use globals */
+                                   AV *ocomppad_name = PL_comppad_name;
+                                   AV *ocomppad = PL_comppad;
+                                   SV **ocurpad = PL_curpad;
+                                   AV *padlist = CvPADLIST(bcv);
+                                   PL_comppad_name = (AV*)AvARRAY(padlist)[0];
+                                   PL_comppad = (AV*)AvARRAY(padlist)[1];
+                                   PL_curpad = AvARRAY(PL_comppad);
+                                   pad_addlex(sv);
+                                   PL_comppad_name = ocomppad_name;
+                                   PL_comppad = ocomppad;
+                                   PL_curpad = ocurpad;
                                    CvCLONE_on(bcv);
+                               }
                                else {
                                    if (ckWARN(WARN_CLOSURE)
                                        && !CvUNIQUE(bcv) && !CvUNIQUE(cv))

diff --git a/proto.h b/proto.h
index 76cb2f3..6f60109 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -865,6 +865,7 @@ STATIC OP*  S_too_few_arguments(pTHX_ OP *o, char* name);
 STATIC OP*     S_too_many_arguments(pTHX_ OP *o, char* name);
 STATIC void    S_op_clear(pTHX_ OP* o);
 STATIC void    S_null(pTHX_ OP* o);
+STATIC PADOFFSET       S_pad_addlex(pTHX_ SV* name);
 STATIC PADOFFSET       S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
 STATIC OP*     S_newDEFSVOP(pTHX);
 STATIC OP*     S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp);

diff --git a/t/op/closure.t b/t/op/closure.t
index 2284be6..52d2272 100755 (executable)
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use Config;
 
-print "1..169\n";
+print "1..170\n";
 
 my $test = 1;
 sub test (&) {
@@ -157,6 +157,22 @@ test {
   &{$foo[4]}(4)
 };
 
+for my $n (0..4) {
+    $foo[$n] = sub {
+                     # no intervening reference to $n here
+                     sub { $n == $_[0] }
+                  };
+}
+
+test {
+  $foo[0]->()->(0) and
+  $foo[1]->()->(1) and
+  $foo[2]->()->(2) and
+  $foo[3]->()->(3) and
+  $foo[4]->()->(4)
+};
+
+
 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
 
 {