In perl.git, the branch smoke-me/abolish-PL_main_start has been updated <http://perl5.git.perl.org/perl.git/commitdiff/347eb578a4abed5822d7cf488bcabbcde1100570?hp=2c247e84d4c0ff4b5c5fe6c10b3257c55520332a>
- Log ----------------------------------------------------------------- commit 347eb578a4abed5822d7cf488bcabbcde1100570 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 5d2791614936a68ca10f5feecc4a326bd83d4715 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 commit 0570ad189783bd8c424fba27af286af5c7a45365 Author: Nicholas Clark <[email protected]> Date: Tue Sep 4 21:55:22 2012 +0200 Document when the early return in Perl_newPROG() is bypassed completely. M op.c ----------------------------------------------------------------------- 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 | 29 ++++++++++++++++++++--------- 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, 102 insertions(+), 87 deletions(-) diff --git a/dump.c b/dump.c index ada6ae9..3749f9f 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); } @@ -2310,8 +2310,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 877e811..d73ad2c 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 9200cc9..e2595ba 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -729,7 +729,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 f57fa7d..5c37523 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 9e176ad..81a58c1 100644 --- a/op.c +++ b/op.c @@ -2995,6 +2995,17 @@ Perl_newPROG(pTHX_ OP *o) maybe other things) also take this path, because they set up PL_main_start and PL_main_root directly, without generating an optree. + + If the parsing the main program aborts (due to parse errors, + or due to BEGIN or similar calling exit), then newPROG() + isn't even called, and hence this code path and its cleanups + are skipped. This shouldn't make a make a difference: + * a non-zero return from perl_parse is a failure, and + perl_destruct() should be called immediately. + * however, if exit(0) is called during the parse, then + perl_parse() returns 0, and perl_run() is called. As + PL_main_start will be NULL, perl_run() will return + promptly, and the exit code will remain 0. */ PL_comppad_name = 0; @@ -3002,14 +3013,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; @@ -7309,7 +7320,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"); @@ -7319,7 +7330,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 8444218..23b95ed 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); @@ -2371,8 +2368,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 } @@ -2386,9 +2383,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 2cc4e91..0ca067c 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 69e18ce..bc9ca20 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1839,7 +1839,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 1477373..f6f6c78 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2996,7 +2996,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)) { @@ -3011,7 +3011,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) { @@ -3085,7 +3085,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 497417c..237c581 100644 --- a/sv.c +++ b/sv.c @@ -12932,7 +12932,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; @@ -13236,9 +13235,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
