[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
Re: closure in closure
On Wed, 15 Dec 1999 22:01:04 PST, Larry Wall wrote:
>Pixel writes:
>: This surprised me:
>:
>: foreach my $t (1..5) {
>: push @bad, sub { sub { $t } };
>: }
>: foreach my $t (1..5) {
>: push @good, sub { my $t = $t; sub { $t } };
>: }
>: print "[", &{&$_}, "]\n" foreach @bad, @good;
>
>Looks to me like pad_findlex() needs to be rewritten to be recursive,
>and upon each return install extra symbol table entries in the
>in-between pads so all the cloning happens right.
This ought to fix it.
Sarathy
gsar@ActiveState.com
-----------------------------------8<-----------------------------------
Change 4834 by gsar@auger on 2000/01/22 08:08:08
fix deeply nested closures that have no references to lexical in
intervening subs
Affected files ...
... //depot/perl/embed.h#154 edit
... //depot/perl/embed.pl#98 edit
... //depot/perl/op.c#238 edit
... //depot/perl/proto.h#188 edit
... //depot/perl/t/op/closure.t#7 edit
Differences ...
==== //depot/perl/embed.h#154 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Sat Jan 22 00:08:13 2000
+++ perl/embed.h Sat Jan 22 00:08:13 2000
@@ -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
==== //depot/perl/embed.pl#98 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~ Sat Jan 22 00:08:13 2000
+++ perl/embed.pl Sat Jan 22 00:08:13 2000
@@ -1929,6 +1929,7 @@
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
==== //depot/perl/op.c#238 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Sat Jan 22 00:08:13 2000
+++ perl/op.c Sat Jan 22 00:08:13 2000
@@ -204,6 +204,31 @@
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 @@
}
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 @@
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))
==== //depot/perl/proto.h#188 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Sat Jan 22 00:08:13 2000
+++ perl/proto.h Sat Jan 22 00:08:13 2000
@@ -865,6 +865,7 @@
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);
==== //depot/perl/t/op/closure.t#7 (xtext) ====
Index: perl/t/op/closure.t
--- perl/t/op/closure.t.~1~ Sat Jan 22 00:08:13 2000
+++ perl/t/op/closure.t Sat Jan 22 00:08:13 2000
@@ -12,7 +12,7 @@
use Config;
-print "1..169\n";
+print "1..170\n";
my $test = 1;
sub test (&) {
@@ -157,6 +157,22 @@
&{$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>.
{
End of Patch.
- Follow-Ups from:
-
Larry Wall <larry@wall.org>
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]