In perl.git, the branch smoke-me/abolish-PL_main_start has been updated <http://perl5.git.perl.org/perl.git/commitdiff/6538aac9758af757d6deae2b05bc1ef2a9cb2b7d?hp=8b31d4e4418231a55583884517e227471284c99f>
- Log ----------------------------------------------------------------- commit 6538aac9758af757d6deae2b05bc1ef2a9cb2b7d Author: Nicholas Clark <[email protected]> Date: Wed Sep 5 14:53:37 2012 +0200 Replace PL_main_root with CvROOT(PL_main_cv), and similar for PL_main_start. This makes PL_main_cv consistent with every other CV, in that CvROOT() and CvSTART() are used to point to the root and start of its optree. The discrepancy arises because PL_main_cv was only added in 5.001 (as part of adding closures), whereas PL_main_root and PL_main_start date from 5.000. M dump.c M embedvar.h M ext/B/B.pm M ext/B/B.xs M ext/Devel-Peek/Peek.pm M ext/Devel-Peek/Peek.xs M intrpvar.h M op.c M perl.c M perl.h M pod/perlvar.pod M pp_ctl.c M sv.c M win32/perlhost.h commit 77037f2c730022fdbc865d3f246780b148a97f4f Author: Nicholas Clark <[email protected]> Date: Wed Sep 5 13:23:49 2012 +0200 A better test for ensuring no loop between typeglobs and symbol tables. Commit e15faf7d09c73a41 in June 2005 removed the reference count loop between typeglobs and symbol tables. However the test that it used happens to depend on the internal flag for global destruction not actually being set until just after the optree for the main program has been freed up, because the last reference keeping the typeglob alive was held by the main program. Hence message from destroy that it was searching for actually happened in perl_destruct(), but before global destruction had been "announced". This commit provides a more robust test, that doesn't rely on the particular order of C code within perl_destruct(). It passes on e15faf7d09c73a41, but fails on e15faf7d09c73a41^. M perl.c M t/op/gv.t M t/uni/gv.t ----------------------------------------------------------------------- Summary of changes: dump.c | 8 ++++---- embedvar.h | 2 -- ext/B/B.pm | 2 +- ext/B/B.xs | 2 +- ext/Devel-Peek/Peek.pm | 2 +- ext/Devel-Peek/Peek.xs | 4 ++-- intrpvar.h | 2 -- op.c | 18 +++++++++--------- perl.c | 41 +++++++++++++++++++---------------------- perl.h | 3 +++ pod/perlvar.pod | 2 +- pp_ctl.c | 6 +++--- sv.c | 4 ---- t/op/gv.t | 36 ++++++++++++++++++++++++++---------- t/uni/gv.t | 44 ++++++++++++++++++++------------------------ win32/perlhost.h | 2 +- 16 files changed, 91 insertions(+), 87 deletions(-) diff --git a/dump.c b/dump.c index 830ab4b..f8d8e48 100644 --- a/dump.c +++ b/dump.c @@ -119,8 +119,8 @@ Perl_dump_all_perl(pTHX_ bool justperl) dVAR; PerlIO_setlinebuf(Perl_debug_log); - if (PL_main_root) - op_dump(PL_main_root); + if (CvROOT(PL_main_cv)) + op_dump(CvROOT(PL_main_cv)); dump_packsubs_perl(PL_defstash, justperl); } @@ -2317,8 +2317,8 @@ void Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL) { PerlIO_setlinebuf(PL_xmlfp); - if (PL_main_root) - op_xmldump(PL_main_root); + if (CvROOT(PL_main_cv)) + op_xmldump(CvROOT(PL_main_cv)); /* someday we might call this, when it outputs XML: */ /* xmldump_packsubs_perl(PL_defstash, justperl); */ if (PL_xmlfp != (PerlIO*)PerlIO_stdout()) diff --git a/embedvar.h b/embedvar.h index b9fabab..0ab1eb6 100644 --- a/embedvar.h +++ b/embedvar.h @@ -209,8 +209,6 @@ #define PL_lockhook (vTHX->Ilockhook) #define PL_madskills (vTHX->Imadskills) #define PL_main_cv (vTHX->Imain_cv) -#define PL_main_root (vTHX->Imain_root) -#define PL_main_start (vTHX->Imain_start) #define PL_mainstack (vTHX->Imainstack) #define PL_markstack (vTHX->Imarkstack) #define PL_markstack_max (vTHX->Imarkstack_max) diff --git a/ext/B/B.pm b/ext/B/B.pm index 1274aaa..7229d53 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.38'; + $B::VERSION = '1.39'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index ad839b5..a165573 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -721,7 +721,7 @@ main_root() ALIAS: main_start = 1 PPCODE: - PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root)); + PUSHs(make_op_object(aTHX_ ix ? CvSTART(PL_main_cv) : CvROOT(PL_main_cv))); UV sub_generation() diff --git a/ext/Devel-Peek/Peek.pm b/ext/Devel-Peek/Peek.pm index 68bd332..7869c81 100644 --- a/ext/Devel-Peek/Peek.pm +++ b/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.10'; +$VERSION = '1.11'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs index d44a90f..978da53 100644 --- a/ext/Devel-Peek/Peek.xs +++ b/ext/Devel-Peek/Peek.xs @@ -382,8 +382,8 @@ DumpProg() PPCODE: { warn("dumpindent is %d", (int)PL_dumpindent); - if (PL_main_root) - op_dump(PL_main_root); + if (CvROOT(PL_main_cv)) + op_dump(CvROOT(PL_main_cv)); } I32 diff --git a/intrpvar.h b/intrpvar.h index 40a6aa1..2caa752 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -391,8 +391,6 @@ PERLVARI(I, op_mask, char *, NULL) /* masked operations for safe evals */ /* current interpreter roots */ PERLVAR(I, main_cv, CV *) -PERLVAR(I, main_root, OP *) -PERLVAR(I, main_start, OP *) PERLVAR(I, eval_root, OP *) PERLVAR(I, eval_start, OP *) diff --git a/op.c b/op.c index 0b969e9..141df30 100644 --- a/op.c +++ b/op.c @@ -3073,14 +3073,14 @@ Perl_newPROG(pTHX_ OP *o) S_op_destroy(aTHX_ o); return; } - PL_main_root = op_scope(sawparens(scalarvoid(o))); + CvROOT(PL_main_cv) = op_scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; - PL_main_start = LINKLIST(PL_main_root); - PL_main_root->op_private |= OPpREFCOUNTED; - OpREFCNT_set(PL_main_root, 1); - PL_main_root->op_next = 0; - CALL_PEEP(PL_main_start); - finalize_optree(PL_main_root); + CvSTART(PL_main_cv) = LINKLIST(CvROOT(PL_main_cv)); + CvROOT(PL_main_cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(PL_main_cv), 1); + CvROOT(PL_main_cv)->op_next = 0; + CALL_PEEP(CvSTART(PL_main_cv)); + finalize_optree(CvROOT(PL_main_cv)); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -7734,7 +7734,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, return; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { - if (PL_main_start) + if (CvROOT(PL_main_cv)) /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); @@ -7744,7 +7744,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, return; } else if (*name == 'I') { if (strEQ(name, "INIT")) { - if (PL_main_start) + if (CvROOT(PL_main_cv)) /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); diff --git a/perl.c b/perl.c index 7d65719..1f9c7a0 100644 --- a/perl.c +++ b/perl.c @@ -716,6 +716,8 @@ perl_destruct(pTHXx) close(fd[1]); } #endif + + PERL_SET_PHASE(PERL_PHASE_DESTRUCT); /* We must account for everything. */ @@ -725,22 +727,15 @@ perl_destruct(pTHXx) -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid op from which the filename structure member is copied. */ PL_curcop = &PL_compiling; - if (PL_main_root) { - /* ensure comppad/curpad to refer to main's pad */ - if (CvPADLIST(PL_main_cv)) { - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); - } - op_free(PL_main_root); - PL_main_root = NULL; - } - PL_main_start = NULL; /* note that PL_main_cv isn't usually actually freed at this point, * due to the CvOUTSIDE refs from subs compiled within it. It will * get freed once all the subs are freed in sv_clean_all(), for * destruct_level > 0 */ - SvREFCNT_dec(PL_main_cv); - PL_main_cv = NULL; - PERL_SET_PHASE(PERL_PHASE_DESTRUCT); + if (PL_main_cv) { + CvDEPTH(PL_main_cv) = 0; + SvREFCNT_dec(PL_main_cv); + PL_main_cv = NULL; + } /* Tell PerlIO we are about to tear things apart in case we have layers which are using resources that should @@ -819,7 +814,7 @@ perl_destruct(pTHXx) #ifdef USE_ITHREADS /* the syntax tree is shared between clones - * so op_free(PL_main_root) only ReREFCNT_dec's + * so op_free(CvROOT(PL_main_cv)) only ReREFCNT_dec's * REGEXPs in the parent interpreter * we need to manually ReREFCNT_dec for the clones */ @@ -1603,12 +1598,14 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) return 0; } - if (PL_main_root) { - op_free(PL_main_root); - PL_main_root = NULL; + if (PL_main_cv) { + if (CvROOT(PL_main_cv)) { + op_free(CvROOT(PL_main_cv)); + CvROOT(PL_main_cv) = NULL; + } + CvSTART(PL_main_cv) = NULL; + SvREFCNT_dec(PL_main_cv); } - PL_main_start = NULL; - SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; time(&PL_basetime); @@ -2372,8 +2369,8 @@ S_run_body(pTHX_ I32 oldscope) call_list(oldscope, PL_initav); } #ifdef PERL_DEBUG_READONLY_OPS - if (PL_main_root && PL_main_root->op_slabbed) - Slab_to_ro(OpSLAB(PL_main_root)); + if (PL_main_cv && CvROOT(PL_main_cv) && CvROOT(PL_main_cv)->op_slabbed) + Slab_to_ro(OpSLAB(CvROOT(PL_main_cv))); #endif } @@ -2387,9 +2384,9 @@ S_run_body(pTHX_ I32 oldscope) PL_restartop = 0; CALLRUNOPS(aTHX); } - else if (PL_main_start) { + else if (PL_main_cv && CvROOT(PL_main_cv) && CvSTART(PL_main_cv)) { CvDEPTH(PL_main_cv) = 1; - PL_op = PL_main_start; + PL_op = CvSTART(PL_main_cv); CALLRUNOPS(aTHX); } my_exit(0); diff --git a/perl.h b/perl.h index 6e18dbf..ce2c40d 100644 --- a/perl.h +++ b/perl.h @@ -4768,6 +4768,9 @@ EXTCONST char *const PL_phase_names[]; # define PL_dirty (PL_phase == PERL_PHASE_DESTRUCT) # define PL_amagic_generation PL_na + +# define PL_main_root CvROOT(PL_main_cv) +# define PL_main_start CvSTART(PL_main_cv) #endif /* !PERL_CORE */ END_EXTERN_C diff --git a/pod/perlvar.pod b/pod/perlvar.pod index fc99b8e..1df48b3 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1850,7 +1850,7 @@ Similar to "CHECK", but for C<INIT>-blocks, not C<CHECK> blocks. =item RUN -The main run-time, i.e. the execution of C<PL_main_root>. +The main run-time, i.e. the execution of C<CvROOT(PL_main_cv)>. =item END diff --git a/pp_ctl.c b/pp_ctl.c index ce88220..9dd2a24 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3000,7 +3000,7 @@ PP(pp_goto) gotoprobe = cx->blk_oldcop->op_sibling; in_block = TRUE; } else - gotoprobe = PL_main_root; + gotoprobe = CvROOT(PL_main_cv); break; case CXt_SUB: if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { @@ -3015,7 +3015,7 @@ PP(pp_goto) if (ix) DIE(aTHX_ "panic: goto, type=%u, ix=%ld", CxTYPE(cx), (long) ix); - gotoprobe = PL_main_root; + gotoprobe = CvROOT(PL_main_cv); break; } if (gotoprobe) { @@ -3089,7 +3089,7 @@ PP(pp_goto) if (do_dump) { #ifdef VMS - if (!retop) retop = PL_main_start; + if (!retop) retop = CvSTART(PL_main_cv); #endif PL_restartop = retop; PL_do_undump = TRUE; diff --git a/sv.c b/sv.c index 89699be..6e527f0 100644 --- a/sv.c +++ b/sv.c @@ -12935,7 +12935,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* internal state */ PL_maxo = proto_perl->Imaxo; - PL_main_start = proto_perl->Imain_start; PL_eval_root = proto_perl->Ieval_root; PL_eval_start = proto_perl->Ieval_start; @@ -13239,9 +13238,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* current interpreter roots */ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); - OP_REFCNT_LOCK; - PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); - OP_REFCNT_UNLOCK; /* runtime control stuff */ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); diff --git a/t/op/gv.t b/t/op/gv.t index e2eae33..b4fc042 100644 --- a/t/op/gv.t +++ b/t/op/gv.t @@ -315,21 +315,37 @@ is($j[0], 1); is ($e, '', '__DIE__ handler never called'); } +# The previous version of this test relied on the fact that PL_main_root is +# freed *just* before global destruction is "declared". This is an unfortunate +# ordering assumption about the C code in perl_destroy + +# It's possible to more easily demonstrate whether typeglobs and symbol +# tables have a mutual loop keeping them alive until global destruction by +# ensuring that any optree that also references the typeglob can be freed +# at a known time (the undef &thwake below), and so one can check whether the +# destructor hooked to $A::B has fired. + { - # Need some sort of die or warn to get the global destruction text if the - # bug is still present - my $output = runperl(prog => <<'EOPROG'); + my $output = runperl(prog => <<'EOPROG', stderr => 1); package M; -$| = 1; -sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} +sub DESTROY { + ++$state; +} package main; -bless \$A::B, q{M}; -*A:: = \*B::; +sub thwacke { + $M::state = 1; + bless \$A::B, q{M}; + *A:: = \*B::; +}; +&thwacke; + +print qq{Before: $M::state\n}; +undef &thwacke; +print qq{After: $M::state\n}; EOPROG - like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); - unlike($output, qr/global destruction/, - "unreferenced symbol tables should be cleaned up immediately"); + like($output, qr/^Before: 1/m, "parsed and ran correctly"); + like($output, qr/^After: 2/m, "DESTROY was called at the correct time"); } # Possibly not the correct test file for these tests. diff --git a/t/uni/gv.t b/t/uni/gv.t index f128ec5..a0663b1 100644 --- a/t/uni/gv.t +++ b/t/uni/gv.t @@ -296,31 +296,27 @@ is($Ｊ[0], 1); } { - SKIP: { - skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2); - # Need some sort of die or warn to get the global destruction text if the - # bug is still present - my $prog = <<'EOPROG'; - use utf8; - use open qw( :utf8 :std ); - package á´¹; - $| = 1; - sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} - package main; - - bless \$Ⱥ::ã , q{á´¹}; - *Ⱥ:: = \*ã ::; + my $output = runperl(prog => <<'EOPROG', stderr => 1); +use utf8; +package á´¹; +sub DESTROY { + ++$state; +} +package main; + +sub Æ { + $á´¹::state = 1; + bless \$Ⱥ::ã , q{á´¹}; + *Ⱥ:: = \*ã ::; +}; +&Æ; + +print qq{Before: $á´¹::state\n}; +undef &Æ; +print qq{After: $á´¹::state\n}; EOPROG - - utf8::decode($prog); - my $output = runperl(prog => $prog); - - require Encode; - $output = Encode::decode("UTF-8", $output); - like($output, qr/^Farewell á´¹=SCALAR/, "DESTROY was called"); - unlike($output, qr/global destruction/, - "unreferenced symbol tables should be cleaned up immediately"); - } + like($output, qr/^Before: 1/m, "parsed and ran correctly"); + like($output, qr/^After: 2/m, "DESTROY was called at the correct time"); } { diff --git a/win32/perlhost.h b/win32/perlhost.h index ae422ef..da041e2 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -1781,7 +1781,7 @@ restart: /* XXX hack to avoid perl_destruct() freeing optree */ win32_checkTLS(my_perl); - PL_main_root = (OP*)NULL; + CvROOT(PL_main_cv) = (OP*)NULL; } win32_checkTLS(my_perl); -- Perl5 Master Repository
