diff options
Diffstat (limited to 'contrib/perl5/ext/B')
| -rw-r--r-- | contrib/perl5/ext/B/B.pm | 10 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B.xs | 14 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Assembler.pm | 4 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/C.pm | 81 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/CC.pm | 27 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Disassembler.pm | 2 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/Makefile.PL | 2 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/README | 4 |
8 files changed, 119 insertions, 25 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index d5137d4..75dcfb3 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -13,7 +13,7 @@ require Exporter; class peekop cast_I32 cstring cchar hash threadsv_names main_root main_start main_cv svref_2object walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info); + parents comppadlist sv_undef compile_stats timing_info init_av); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -530,6 +530,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item XSUBANY +=item CvFLAGS + =back =head2 B::HV METHODS @@ -576,7 +578,7 @@ This returns the function name as a string (e.g. pp_add, pp_rv2av). =item desc -This returns the op description from the global C op_desc array +This returns the op description from the global C PL_op_desc array (e.g. "addition" "array deref"). =item targ @@ -720,6 +722,10 @@ get an initial "handle" on an internal object. Return the (faked) CV corresponding to the main part of the Perl program. +=item init_av + +Returns the AV object (i.e. in class B::AV) representing INIT blocks. + =item main_root Returns the root op (i.e. an object in the appropriate B::OP-derived diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 8dbc915..6610ae8 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -267,7 +267,8 @@ static SV * cchar(SV *sv) { SV *sstr = newSVpv("'", 0); - char *s = SvPV(sv, PL_na); + STRLEN n_a; + char *s = SvPV(sv, n_a); if (*s == '\'') sv_catpv(sstr, "\\'"); @@ -437,6 +438,7 @@ BOOT: INIT_SPECIALSV_LIST; #define B_main_cv() PL_main_cv +#define B_init_av() PL_initav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) @@ -444,6 +446,9 @@ BOOT: #define B_sv_yes() &PL_sv_yes #define B_sv_no() &PL_sv_no +B::AV +B_init_av() + B::CV B_main_cv() @@ -1164,6 +1169,13 @@ CvXSUBANY(cv) CODE: ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); +MODULE = B PACKAGE = B::CV + +U8 +CvFLAGS(cv) + B::CV cv + + MODULE = B PACKAGE = B::HV PREFIX = Hv STRLEN diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index defcbdf..06e00ad 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -53,6 +53,8 @@ sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here +sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -78,7 +80,7 @@ sub B::Asmdata::PUT_PV { error "bad string argument: $arg" unless defined($arg); return pack("N", length($arg)) . $arg; } -sub B::Asmdata::PUT_comment { +sub B::Asmdata::PUT_comment_t { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index 0b7d6eb..e695cc2 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -13,7 +13,7 @@ use Exporter (); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names); + threadsv_names main_cv init_av); use B::Asmdata qw(@specialsv_name); use FileHandle; @@ -44,7 +44,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect); + $xrvsect, $xpvbmsect, $xpviosect, $bootstrap); sub walk_and_save_optree; my $saveoptree_callback = \&walk_and_save_optree; @@ -596,10 +596,15 @@ sub B::CV::save { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug } - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0", + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE})); + $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); + + if (${$cv->OUTSIDE} == ${main_cv()}){ + $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + } + if ($$gv) { $gv->save; $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); @@ -691,7 +696,7 @@ sub B::GV::save { } my $gvfilegv = $gv->FILEGV; if ($$gvfilegv) { - $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv)); + $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); # warn "GV::save GvFILEGV(*$name)\n"; # debug $gvfilegv->save; } @@ -847,6 +852,7 @@ sub output_all { $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); + $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); $symsect->output(\*STDOUT, "#define %s\n"); print "\n"; output_declarations(); @@ -1046,30 +1052,61 @@ sub save_object { foreach $sv (@_) { svref_2object($sv)->save; } -} +} + +sub Dummy_BootStrap { } sub B::GV::savecv { my $gv = shift; my $cv = $gv->CV; my $name = $gv->NAME; - if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) { + if ($$cv) { + if ($name eq "bootstrap" && $cv->XSUB) { + my $file = $cv->FILEGV->SV->PV; + $bootstrap->add($file); + my $name = $gv->STASH->NAME.'::'.$name; + no strict 'refs'; + *{$name} = \&Dummy_BootStrap; + $cv = $gv->CV; + } if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $name, $$cv, $$gv); } + my $package=$gv->STASH->NAME; + # This seems to undo all the ->isa and prefix stuff we do below + # so disable again for now + if (0 && ! grep(/^$package$/,@unused_sub_packages)){ + warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) + if $debug_cv; + return ; + } $gv->save; } + elsif ($name eq 'ISA') + { + $gv->save; + } + } + + sub save_unused_subs { my %search_pack; map { $search_pack{$_} = 1 } @_; + @unused_sub_packages=@_; no strict qw(vars refs); walksymtable(\%{"main::"}, "savecv", sub { my $package = shift; $package =~ s/::$//; + return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. #warn "Considering $package\n";#debug return 1 if exists $search_pack{$package}; + #sub try for a partial match + if (grep(/^$package\:\:/,@unused_sub_packages)){ + return 1; + } #warn " (nothing explicit)\n";#debug # Omit the packages which we use (and which cause grief # because of fancy "goto &$AUTOLOAD" stuff). @@ -1079,10 +1116,21 @@ sub save_unused_subs { || $package eq "SelectSaver") { return 0; } - my $m; - foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { + foreach my $u (keys %search_pack) { + if ($package =~ /^${u}::/) { + warn "$package starts with $u\n"; + return 1 + } + if ($package->isa($u)) { + warn "$package isa $u\n"; + return 1 + } + return 1 if $package->isa($u); + } + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { if (defined(&{$package."::$m"})) { warn "$package has method $m: -u$package assumed\n";#debug + push @unused_sub_package, $package; return 1; } } @@ -1091,14 +1139,25 @@ sub save_unused_subs { } sub save_main { + warn "Walking tree\n"; + my $curpad_nam = (comppadlist->ARRAY)[0]->save; my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $init_av = init_av->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; save_unused_subs(@unused_sub_packages); $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_curpad = AvARRAY($curpad_sym);"); + "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + warn "Writing output\n"; output_boilerplate(); print "\n"; output_all("perl_init"); @@ -1118,7 +1177,7 @@ sub init_sections { xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect); + xpvio => \$xpviosect, bootstrap => \$bootstrap); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { $$sectref = new B::Section $name, \%symtable, 0; diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index 9991d8e..d200d70 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -878,7 +878,7 @@ sub pp_sassign { } runtime("SvSETMAGIC(TOPs);"); } else { - my $dst = pop @stack; + my $dst = $stack[-1]; my $type = $dst->{type}; runtime("sv = POPs;"); runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); @@ -946,13 +946,25 @@ sub pp_entersub { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); my $sym = doop($op); - runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;"); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;}"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_goto{ + + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); + invalidate_lexicals() unless $skip_invalidate{$ppname}; + return $op->next; +} sub pp_enterwrite { my $op = shift; pp_entersub($op); @@ -1051,7 +1063,7 @@ sub pp_return { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); doop($op); - runtime("PUTBACK;", "return 0;"); + runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;"); $know_op = 0; return $op->next; } @@ -1344,7 +1356,7 @@ sub cc { $need_freetmps = 0; } if (!$$op) { - runtime("PUTBACK;", "return 0;"); + runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;"); } elsif ($done{$$op}) { runtime(sprintf("goto %s;", label($op))); } @@ -1375,6 +1387,7 @@ sub cc_obj { sub cc_main { my @comppadlist = comppadlist->ARRAY; + my $curpad_nam = $comppadlist[0]->save; my $curpad_sym = $comppadlist[1]->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); save_unused_subs(@unused_sub_packages); @@ -1384,7 +1397,9 @@ sub cc_main { if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", - "PL_curpad = AvARRAY($curpad_sym);"); + "PL_curpad = AvARRAY($curpad_sym);", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); } output_boilerplate(); print "\n"; diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index f26441d..4a008a3 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -77,7 +77,7 @@ sub GET_PV { } } -sub GET_comment { +sub GET_comment_t { my $fh = shift; my ($str, $c); while (defined($c = $fh->getc) && $c ne "\n") { diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index cdcc4ed..80e5e1b 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -16,7 +16,7 @@ if ($^O eq 'MSWin32') { WriteMakefile( NAME => "B", VERSION => "a5", - MAN3PODS => ' ', + MAN3PODS => {}, clean => { FILES => "perl$e byteperl$e *$o B.c *~" } diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README index 4e4ed25..fa3f085 100644 --- a/contrib/perl5/ext/B/README +++ b/contrib/perl5/ext/B/README @@ -20,8 +20,8 @@ in the file named "Artistic". If not, you can get one from the Perl distribution. You should also have received a copy of the GNU General Public License, in the file named "Copying". If not, you can get one - from the Perl distribution or else write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + from the Perl distribution or else write to the Free Software Foundation, + Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. CHANGES |
