# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
+package B::C::Section;
+use B ();
+use base B::Section;
+
+sub new
+{
+ my $class = shift;
+ my $o = $class->SUPER::new(@_);
+ push(@$o,[]);
+ return $o;
+}
+
+sub add
+{
+ my $section = shift;
+ push(@{$section->[-1]},@_);
+}
+
+sub index
+{
+ my $section = shift;
+ return scalar(@{$section->[-1]})-1;
+}
+
+sub output
+{
+ my ($section, $fh, $format) = @_;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+ foreach (@{$section->[-1]})
+ {
+ s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
+ printf $fh $format, $_;
+ }
+}
+
package B::C;
use Exporter ();
@ISA = qw(Exporter);
my %symtable;
my $warn_undefined_syms;
my $verbose;
-my @unused_sub_packages;
+my %unused_sub_packages;
my $nullop_count;
-my $pv_copy_on_grow;
+my $pv_copy_on_grow = 0;
my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
my @threadsv_names;
}
# Code sections
-my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
+my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
$gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
$pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
$xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
}
sub savepv {
- my $pv = shift;
+ my $pv = shift;
+ $pv = '' unless defined $pv; # Is this sane ?
my $pvsym = 0;
my $pvmax = 0;
- if ($pv_copy_on_grow) {
+ if ($pv_copy_on_grow) {
my $cstring = cstring($pv);
if ($cstring ne "0") { # sic
$pvsym = sprintf("pv%d", $pv_index++);
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
- my $pv = $sv->PV;
+ my $pv = $sv->PV;
+ $pv = '' unless defined $pv;
my $len = length($pv);
my ($pvsym, $pvmax) = savepv($pv);
$xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
- $xrvsect->add($sv->RV->save);
+ my $rv = $sv->RV->save;
+ $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
+ $xrvsect->add($rv);
$svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
$xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
else {
warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
$cvstashname, $cvname); # debug
- }
+ }
+ $pv = '' unless defined $pv; # Avoid use of undef warnings
$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,
my $sym = objsym($io);
return $sym if defined $sym;
my $pv = $io->PV;
+ $pv = '' unless defined $pv;
my $len = length($pv);
$xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
$len, $len+1, $io->IVX, $io->NVX, $io->LINES,
my $section;
my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
$listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
- $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
+ $loopsect, $copsect, $svsect, $xpvsect,
$xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
$xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
$bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
sub Dummy_BootStrap { }
-sub B::GV::savecv {
- my $gv = shift;
- my $cv = $gv->CV;
- my $name = $gv->NAME;
- 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;
- if ( ! grep(/^$package$/,@unused_sub_packages)){
- warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME)
- if $debug_cv;
- return ;
- }
- $gv->save;
+sub B::GV::savecv
+{
+ my $gv = shift;
+ my $package=$gv->STASH->NAME;
+ my $name = $gv->NAME;
+ my $cv = $gv->CV;
+ return unless ($$cv || $name eq 'ISA');
+ # We may be looking at this package just because it is a branch in the
+ # symbol table which is on the path to a package which we need to save
+ # e.g. this is 'Getopt' and wee need to save 'Getopt::Long'
+ #
+ if ($$cv && $name eq "bootstrap" && $cv->XSUB)
+ {
+ my $file = $cv->FILEGV->SV->PV;
+ $bootstrap->add($file);
+ }
+ unless ($unused_sub_packages{$package})
+ {
+ warn sprintf("omitting cv $name in %s\n", $package) if $$cv; # if $debug_cv;
+ return ;
+ }
+ if ($$cv)
+ {
+ if ($name eq "bootstrap" && $cv->XSUB)
+ {
+ my $name = $gv->STASH->NAME.'::'.$name;
+ no strict 'refs';
+ *{$name} = \&Dummy_BootStrap;
+ $cv = $gv->CV;
}
- elsif ($name eq 'ISA')
- {
- $gv->save;
- }
+ warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+ $package, $name, $$cv, $$gv) if ($debug_cv);
+ $gv->save;
+ }
+ elsif ($name eq 'ISA')
+ {
+ $gv->save;
+ }
+}
+sub mark_package
+{
+ my $package = shift;
+ unless ($unused_sub_packages{$package})
+ {
+ no strict 'refs';
+ $unused_sub_packages{$package} = 1;
+ if (defined(@{$package.'::ISA'}))
+ {
+ foreach my $isa (@{$package.'::ISA'})
+ {
+ if ($isa eq 'DynaLoader')
+ {
+ unless (defined(&{$package.'::bootstrap'}))
+ {
+ warn "Forcing bootstrap of $package\n";
+ eval { $package->bootstrap };
+ }
+ }
+ else
+ {
+ unless ($unused_sub_packages{$isa})
+ {
+ warn "$isa saved (it is in $package\'s \@ISA)\n";
+ mark_package($isa);
+ }
+ }
+ }
+ }
+ }
+ return 1;
+}
+
+sub should_save
+{
+ no strict qw(vars refs);
+ my $package = shift;
+ $package =~ s/::$//;
+ return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
+ warn "Considering $package\n";#debug
+ foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
+ {
+ # If this package is a prefix to something we are saving, traverse it
+ # but do not mark it for saving if it is not already
+ # e.g. to get to Getopt::Long we need to traverse Getopt but need
+ # not save Getopt
+ return 1 if ($u =~ /^$package\:\:/);
+ }
+ if (exists $unused_sub_packages{$package})
+ {
+ warn "Cached $package is ".$unused_sub_packages{$package}."\n";
+ return $unused_sub_packages{$package}
+ }
+ # Omit the packages which we use (and which cause grief
+ # because of fancy "goto &$AUTOLOAD" stuff).
+ # XXX Surely there must be a nicer way to do this.
+ if ($package eq "FileHandle" || $package eq "Config" ||
+ $package eq "SelectSaver" || $package =~/^B::/)
+ {
+ return $unused_sub_packages{$package} = 0;
+ }
+ # Now see if current package looks like an OO class this is probably too strong.
+ foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
+ {
+ if ($package->can($m))
+ {
+ warn "$package has method $m: saving package\n";#debug
+ return mark_package($package);
+ }
+ }
+ return $unused_sub_packages{$package} = 0;
}
+sub walkpackages
+{
+ my ($symref, $recurse, $prefix) = @_;
+ my $sym;
+ my $ref;
+ no strict 'vars';
+ local(*glob);
+ $prefix = '' unless defined $prefix;
+ while (($sym, $ref) = each %$symref)
+ {
+ *glob = $ref;
+ if ($sym =~ /::$/)
+ {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && &$recurse($sym))
+ {
+ walkpackages(\%glob, $recurse, $sym);
+ }
+ }
+ }
+}
-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};
- #warn " (nothing explicit)\n";#debug
- # Omit the packages which we use (and which cause grief
- # because of fancy "goto &$AUTOLOAD" stuff).
- # XXX Surely there must be a nicer way to do this.
- if ($package eq "FileHandle"
- || $package eq "Config"
- || $package eq "SelectSaver") {
- return 0;
- }
- foreach my $u (keys %search_pack) {
- if ($package->isa($u)) {
- warn "$package isa $u\n" if defined $debug_cv;
- push @unused_sub_package, $package;
- return 1
- }
- if ($package =~ /^${u}::/) {
- warn "$package starts with $u\n" if defined $debug_cv;
- return 1
- }
- }
- 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;
- }
- }
- return 0;
- });
+sub save_unused_subs
+{
+ no strict qw(refs);
+ warn "Prescan\n";
+ walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
+ warn "Saving methods\n";
+ walksymtable(\%{"main::"}, "savecv", \&should_save);
}
sub save_main {
- warn "Walking tree\n";
+ warn "Starting compile\n";
+ foreach my $pack (keys %unused_sub_packages)
+ {
+ mark_package($pack);
+ }
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;
+ warn "Walking tree\n";
walkoptree(main_root, "save");
warn "done main optree, walking symtable for extras\n" if $debug_cv;
- save_unused_subs(@unused_sub_packages);
+ save_unused_subs();
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
sprintf("PL_main_start = s\\_%x;", ${main_start()}),
sub init_sections {
my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
binop => \$binopsect, condop => \$condopsect,
- cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
+ cop => \$copsect, gvop => \$gvopsect,
listop => \$listopsect, logop => \$logopsect,
loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
xpvio => \$xpviosect, bootstrap => \$bootstrap);
my ($name, $sectref);
while (($name, $sectref) = splice(@sections, 0, 2)) {
- $$sectref = new B::Section $name, \%symtable, 0;
+ $$sectref = new B::C::Section $name, \%symtable, 0;
}
}
$verbose = 1;
} elsif ($opt eq "u") {
$arg ||= shift @options;
- push(@unused_sub_packages, $arg);
+ $unused_sub_packages{$arg} = undef;
} elsif ($opt eq "f") {
$arg ||= shift @options;
if ($arg eq "cog") {
projects / p5sagit/p5-mst-13.2.git / commitdiff