c.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

#      C.pm
#
#      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 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 main_cv init_av opnumber amagic_generation
	 AVf_REAL HEf_SVKEY);
use B::Asmdata qw(@specialsv_name);

use FileHandle;
use Carp;
use strict;
use Config;

my $hv_index = 0;
my $gv_index = 0;
my $re_index = 0;
my $pv_index = 0;
my $anonsub_index = 0;
my $initsub_index = 0;

my %symtable;
my %xsub;
my $warn_undefined_syms;
my $verbose;
my %unused_sub_packages;
my $nullop_count;
my $pv_copy_on_grow = 0;
my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
my $max_string_len;

my @threadsv_names;
BEGIN {
    @threadsv_names = threadsv_names();
}

# Code sections
my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, 
    $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
    $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
    $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
    $xrvsect, $xpvbmsect, $xpviosect );

sub walk_and_save_optree;
my $saveoptree_callback = \&walk_and_save_optree;
sub set_callback { $saveoptree_callback = shift }
sub saveoptree { &$saveoptree_callback(@_) }

sub walk_and_save_optree {
    my ($name, $root, $start) = @_;
    walkoptree($root, "save");
    return objsym($start);
}

# Current workaround/fix for op_free() trying to free statically
# defined OPs is to set op_seq = -1 and check for that in op_free().
# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
# so that it can be changed back easily if necessary. In fact, to
# stop compilers from moaning about a U16 being initialised with an
# uncast -1 (the printf format is %d so we can't tweak it), we have
# to "know" that op_seq is a U16 and use 65535. Ugh.
my $op_seq = 65535;

# 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) = @_;
    my $sym = sprintf("s\\_%x", $$obj);
    $symtable{$sym} = $value;
}

sub objsym {
    my $obj = shift;
    return $symtable{sprintf("s\\_%x", $$obj)};
}

sub getsym {
    my $sym = shift;
    my $value;

    return 0 if $sym eq "sym_0";	# special case
    $value = $symtable{$sym};
    if (defined($value)) {
	return $value;
    } else {
	warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
	return "UNUSED";
    }
}

sub savepv {
    my $pv = shift;         
    $pv    = '' unless defined $pv;  # Is this sane ?
    my $pvsym = 0;
    my $pvmax = 0;
    if ($pv_copy_on_grow) { 
	my $cstring = cstring($pv);
	if ($cstring ne "0") { # sic
	    $pvsym = sprintf("pv%d", $pv_index++);
	    $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
	}
    } else {
	$pvmax = length($pv) + 1;
    }
    return ($pvsym, $pvmax);
}

sub B::OP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    my $type = $op->type;
    $nullop_count++ unless $type;
    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])));
    }
    $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x",
			 ${$op->next}, ${$op->sibling}, $op->targ,
			 $type, $op_seq, $op->flags, $op->private));
    my $ix = $opsect->index;
    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "&op_list[$ix]");
}

sub B::FAKEOP::new {
    my ($class, %objdata) = @_;
    bless \%objdata, $class;
}

sub B::FAKEOP::save {
    my ($op, $level) = @_;
    $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x",
			 $op->next, $op->sibling, $op->targ,
			 $op->type, $op_seq, $op->flags, $op->private));
    my $ix = $opsect->index;
    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    return "&op_list[$ix]";
}

sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
sub B::FAKEOP::type { $_[0]->{type} || 0}
sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
sub B::FAKEOP::private { $_[0]->{private} || 0 }

sub B::UNOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
			   ${$op->next}, ${$op->sibling},
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, ${$op->first}));
    my $ix = $unopsect->index;
    $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&unop_list[$ix]");
}

sub B::BINOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
			    ${$op->next}, ${$op->sibling},
			    $op->targ, $op->type, $op_seq, $op->flags,
			    $op->private, ${$op->first}, ${$op->last}));
    my $ix = $binopsect->index;
    $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&binop_list[$ix]");
}

sub B::LISTOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
			     ${$op->next}, ${$op->sibling},
			     $op->targ, $op->type, $op_seq, $op->flags,
			     $op->private, ${$op->first}, ${$op->last}));
    my $ix = $listopsect->index;
    $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&listop_list[$ix]");
}

sub B::LOGOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
			    ${$op->next}, ${$op->sibling},
			    $op->targ, $op->type, $op_seq, $op->flags,
			    $op->private, ${$op->first}, ${$op->other}));
    my $ix = $logopsect->index;
    $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&logop_list[$ix]");
}

sub B::LOOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
    #		 peekop($op->redoop), peekop($op->nextop),
    #		 peekop($op->lastop)); # debug
    $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
			   ${$op->next}, ${$op->sibling},
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, ${$op->first}, ${$op->last},
			   ${$op->redoop}, ${$op->nextop},
			   ${$op->lastop}));
    my $ix = $loopsect->index;
    $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&loop_list[$ix]");
}

sub B::PVOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL,  %u, %u, %u, 0x%x, 0x%x, %s",
			   ${$op->next}, ${$op->sibling},
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, cstring($op->pv)));
    my $ix = $pvopsect->index;
    $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    savesym($op, "(OP*)&pvop_list[$ix]");
}

sub B::SVOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    my $svsym = $op->sv->save;
    $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
			   ${$op->next}, ${$op->sibling},
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private));
    my $ix = $svopsect->index;
    $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
    savesym($op, "(OP*)&svop_list[$ix]");
}

sub B::PADOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
			   ${$op->next}, ${$op->sibling},
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private));
    $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
    my $ix = $padopsect->index;
    $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
    savesym($op, "(OP*)&padop_list[$ix]");
}

sub B::COP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
	if $debug_cops;
    $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
			  ${$op->next}, ${$op->sibling},
			  $op->targ, $op->type, $op_seq, $op->flags,
			  $op->private, cstring($op->label), $op->cop_seq,
			  $op->arybase, $op->line));
    my $ix = $copsect->index;
    $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
    $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
	       sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
    savesym($op, "(OP*)&cop_list[$ix]");
}

sub B::PMOP::save {
    my ($op, $level) = @_;
    my $sym = objsym($op);
    return $sym if defined $sym;
    my $replroot = $op->pmreplroot;
    my $replstart = $op->pmreplstart;
    my $replrootfield = sprintf("s\\_%x", $$replroot);
    my $replstartfield = sprintf("s\\_%x", $$replstart);
    my $gvsym;
    my $ppaddr = $op->ppaddr;
    if ($$replroot) {
	# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
	# argument to a split) stores a GV in op_pmreplroot instead
	# of a substitution syntax tree. We don't want to walk that...
	if ($op->name eq "pushre") {
	    $gvsym = $replroot->save;
#	    warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
	    $replrootfield = 0;
	} else {
	    $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
	}
    }
    # pmnext handling is broken in perl itself, I think. Bad op_pmnext
    # fields aren't noticed in perl's runtime (unless you try reset) but we
    # segfault when trying to dereference it to find op->op_pmnext->op_type
    $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
			   ${$op->next}, ${$op->sibling}, $op->targ,
			   $op->type, $op_seq, $op->flags, $op->private,
			   ${$op->first}, ${$op->last}, 
			   $replrootfield, $replstartfield,
			   $op->pmflags, $op->pmpermflags,));
    my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
    $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
    my $re = $op->precomp;
    if (defined($re)) {
	my $resym = sprintf("re%d", $re_index++);
	$decl->add(sprintf("static char *$resym = %s;", cstring($re)));
	$init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
			   length($re)));
    }
    if ($gvsym) {
	$init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
    }
    savesym($op, "(OP*)&$pm");
}

sub B::SPECIAL::save {
    my ($sv) = @_;
    # special case: $$sv is not the address but an index into specialsv_list
#   warn "SPECIAL::save specialsv $$sv\n"; # debug
    my $sym = $specialsv_name[$$sv];
    if (!defined($sym)) {
	confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
    }
    return $sym;
}

sub B::OBJECT::save {}

sub B::NULL::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
#   warn "Saving SVt_NULL SV\n"; # debug
    # debug
    if ($$sv == 0) {
    	warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
	return savesym($sv, "Nullsv /* XXX */");
    }
    $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::IV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
    $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
			 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::NV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $val= $sv->NVX;