From: Nick Ing-Simmons Date: Fri, 4 Dec 1998 21:58:49 +0000 (+0000) Subject: Snapshot of re-worked B::C which compiles Tk apps at least as X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66a2622e10d775dab53a7b8c0d66ec80b7095bf7;p=p5sagit%2Fp5-mst-13.2.git Snapshot of re-worked B::C which compiles Tk apps at least as well as _54, but with pre-scan for classes and save the ISA scheme. p4raw-id: //depot/perl@2451 --- diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 4591859..da8c450 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -5,6 +5,42 @@ # 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); @@ -30,9 +66,9 @@ my $initsub_index = 0; 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; @@ -41,7 +77,7 @@ BEGIN { } # 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, @@ -99,10 +135,11 @@ sub getsym { } 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++); @@ -389,7 +426,8 @@ sub B::PVNV::save { 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", @@ -490,7 +528,9 @@ sub B::RV::save { 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)); @@ -600,7 +640,8 @@ sub B::CV::save { 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, @@ -818,6 +859,7 @@ sub B::IO::save { 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, @@ -854,7 +896,7 @@ sub output_all { 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"); @@ -1061,92 +1103,166 @@ sub save_object { 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()}), @@ -1167,7 +1283,7 @@ sub save_main { 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, @@ -1179,7 +1295,7 @@ sub init_sections { 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; } } @@ -1225,7 +1341,7 @@ sub compile { $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") {