# C.pm
#
-# Copyright (c) 1996, 1997 Malcolm Beattie
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
#
# 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);
-@EXPORT_OK = qw(output_all output_boilerplate output_main
- init_sections set_callback save_unused_subs objsym);
+@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
+ init_sections set_callback save_unused_subs objsym save_context);
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 opnumber);
use B::Asmdata qw(@specialsv_name);
use FileHandle;
my $re_index = 0;
my $pv_index = 0;
my $anonsub_index = 0;
+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;
}
# 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,
- $xrvsect, $xpvbmsect, $xpviosect);
+ $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
sub walk_and_save_optree;
my $saveoptree_callback = \&walk_and_save_optree;
sub AVf_REAL () { 1 }
-# XXX This shouldn't really be hardcoded here but it saves
-# looking up the name of every BASEOP in B::OP
-sub OP_THREADSV () { 345 }
+# Look this up here so we can do just a number compare
+# rather than looking up the name of every BASEOP in B::OP
+my $OP_THREADSV = opnumber('threadsv');
sub savesym {
my ($obj, $value) = @_;
}
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 ($op, $level) = @_;
my $type = $op->type;
$nullop_count++ unless $type;
- if ($type == OP_THREADSV) {
+ if ($type == $OP_THREADSV) {
# saves looking up ppaddr but it's a bit naughty to hard code this
$init->add(sprintf("(void)find_threadsv(%s);",
cstring($threadsv_names[$op->targ])));
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));
$ppname .= ($stashname eq "main") ?
$gvname : "$stashname\::$gvname";
$ppname =~ s/::/__/g;
+ if ($gvname eq "INIT"){
+ $ppname .= "_$initsub_index";
+ $initsub_index++;
+ }
}
}
if (!$ppname) {
else {
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",
+ }
+ $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,
- $$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));
}
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;
}
my ($key, $value) = splice(@contents, 0, 2);
$init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
cstring($key),length($key),$value, hash($key)));
+# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+# cstring($key),length($key),$value, 0));
}
$init->add("}");
}
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");
$symsect->output(\*STDOUT, "#define %s\n");
print "\n";
output_declarations();
perl_init_i18nl10n(1);
- if (!do_undump) {
+ if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
}
#ifdef CSH
- if (!cshlen)
- cshlen = strlen(cshname);
+ if (!PL_cshlen)
+ PL_cshlen = strlen(PL_cshname);
#endif
#ifdef ALLOW_PERL_OPTIONS
exit( exitstatus );
sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
- main_cv = compcv;
- compcv = 0;
+ PL_main_cv = PL_compcv;
+ PL_compcv = 0;
exitstatus = perl_init();
if (exitstatus)
foreach $sv (@_) {
svref_2object($sv)->save;
}
+}
+
+sub Dummy_BootStrap { }
+
+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;
+ }
+ 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 B::GV::savecv {
- my $gv = shift;
- my $cv = $gv->CV;
- my $name = $gv->NAME;
- if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
- if ($debug_cv) {
- warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
- $gv->STASH->NAME, $name, $$cv, $$gv);
- }
- $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|IO)::/)
+ {
+ 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 save_unused_subs {
- my %search_pack;
- map { $search_pack{$_} = 1 } @_;
- no strict qw(vars refs);
- walksymtable(\%{"main::"}, "savecv", sub {
- my $package = shift;
- $package =~ s/::$//;
- #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;
- }
- my $m;
- foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
- if (defined(&{$package."::$m"})) {
- warn "$package has method $m: -u$package assumed\n";#debug
- return 1;
- }
- }
- return 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
+{
+ 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_context
+{
+ my $curpad_nam = (comppadlist->ARRAY)[0]->save;
+ my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ my $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
+ $init->add( "PL_curpad = AvARRAY($curpad_sym);",
+ "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));");
}
sub save_main {
- my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ warn "Starting compile\n";
+ foreach my $pack (keys %unused_sub_packages)
+ {
+ mark_package($pack);
+ }
+ 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);
-
- $init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
- sprintf("main_start = s\\_%x;", ${main_start()}),
- "curpad = AvARRAY($curpad_sym);");
+ save_unused_subs();
+ my $init_av = init_av->save;
+ $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+ sprintf("PL_main_start = s\\_%x;", ${main_start()}),
+ "PL_initav = $init_av;");
+ save_context();
+ warn "Writing output\n";
output_boilerplate();
print "\n";
output_all("perl_init");
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,
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;
+ $$sectref = new B::C::Section $name, \%symtable, 0;
}
+}
+
+sub mark_unused
+{
+ my ($arg,$val) = @_;
+ $unused_sub_packages{$arg} = $val;
}
sub compile {
$verbose = 1;
} elsif ($opt eq "u") {
$arg ||= shift @options;
- push(@unused_sub_packages, $arg);
+ mark_unused($arg,undef);
} elsif ($opt eq "f") {
$arg ||= shift @options;
if ($arg eq "cog") {
=head1 DESCRIPTION
-See F<ext/B/README>.
+This compiler backend takes Perl source and generates C source code
+corresponding to the internal structures that perl uses to run
+your program. When the generated C source is compiled and run, it
+cuts out the time which perl would have taken to load and parse
+your program into its internal semi-compiled form. That means that
+compiling with this backend will not help improve the runtime
+execution speed of your program but may improve the start-up time.
+Depending on the environment in which your program runs this may be
+either a help or a hindrance.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-uPackname>
+
+Force apparently unused subs from package Packname to be compiled.
+This allows programs to use eval "foo()" even when sub foo is never
+seen to be used at compile time. The down side is that any subs which
+really are never used also have code generated. This option is
+necessary, for example, if you have a signal handler foo which you
+initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Do>
+
+OPs, prints each OP as it's processed
+
+=item B<-Dc>
+
+COPs, prints COPs as processed (incl. file & line num)
+
+=item B<-DA>
+
+prints AV information on saving
+
+=item B<-DC>
+
+prints CV information on saving
+
+=item B<-DM>
+
+prints MAGIC information on saving
+
+=item B<-f>
+
+Force optimisations on or off one at a time.
+
+=item B<-fcog>
+
+Copy-on-grow: PVs declared and initialised statically.
+
+=item B<-fno-cog>
+
+No copy-on-grow.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
+B<-O1> and higher set B<-fcog>.
+
+=head1 EXAMPLES
+
+ perl -MO=C,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
=head1 AUTHOR