#      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;
use Exporter ();
@ISA = qw(Exporter);
@EXPORT_OK = qw(output_all output_boilerplate output_main
		init_sections set_callback save_unused_subs objsym);

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);
use B::Asmdata qw(@specialsv_name);

use FileHandle;
use Carp;
use strict;

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

my %symtable;
my $warn_undefined_syms;
my $verbose;
my @unused_sub_packages;
my $nullop_count;
my $pv_copy_on_grow;
my ($debug_cops, $debug_av, $debug_cv, $debug_mg);

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

# Code sections
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);

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;

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 }

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;
    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 $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, %s, %u, %u, %u, 0x%x, 0x%x",
			 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
			 $type, $op_seq, $op->flags, $op->private));
    savesym($op, sprintf("&op_list[%d]", $opsect->index));
}

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

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

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) = @_;
    $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, ${$op->first}));
    savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
}

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

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

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

sub B::CONDOP::save {
    my ($op, $level) = @_;
    $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
			     ${$op->next}, ${$op->sibling}, $op->ppaddr,
			     $op->targ, $op->type, $op_seq, $op->flags,
			     $op->private, ${$op->first}, ${$op->true},
			     ${$op->false}));
    savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
}

sub B::LOOP::save {
    my ($op, $level) = @_;
    #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, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, ${$op->first}, ${$op->last},
			   $op->children, ${$op->redoop}, ${$op->nextop},
			   ${$op->lastop}));
    savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
}

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

sub B::SVOP::save {
    my ($op, $level) = @_;
    my $svsym = $op->sv->save;
    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private, "(SV*)$svsym"));
    savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
}

sub B::GVOP::save {
    my ($op, $level) = @_;
    my $gvsym = $op->gv->save;
    $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
			   $op->targ, $op->type, $op_seq, $op->flags,
			   $op->private));
    $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
    savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
}

sub B::COP::save {
    my ($op, $level) = @_;
    my $gvsym = $op->filegv->save;
    my $stashsym = $op->stash->save;
    warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
	if $debug_cops;
    $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
			  ${$op->next}, ${$op->sibling}, $op->ppaddr,
			  $op->targ, $op->type, $op_seq, $op->flags,
			  $op->private, cstring($op->label), $op->cop_seq,
			  $op->arybase, $op->line));
    my $copix = $copsect->index;
    $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
	       sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
    savesym($op, "(OP*)&cop_list[$copix]");
}

sub B::PMOP::save {
    my ($op, $level) = @_;
    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 ($ppaddr eq "pp_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, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
			   ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
			   $op->type, $op_seq, $op->flags, $op->private,
			   ${$op->first}, ${$op->last}, $op->children,
			   $replrootfield, $replstartfield,
			   $op->pmflags, $op->pmpermflags,));
    my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
    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, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
}

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";
    #}
    $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $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 + 1, $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;
    $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
			 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVLV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    my ($lvtarg, $lvtarg_sym);
    $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, 
			    $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
    $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
			 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
			   $xpvlvsect->index, cstring($pv), $len));
    }
    $sv->save_magic;
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVIV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
    $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
			 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
			   $xpvivsect->index, cstring($pv), $len));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVNV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
			 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
			   $xpvnvsect->index, cstring($pv), $len));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::BM::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV . "\0" . $sv->TABLE;
    my $len = length($pv);
    $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
			    $len, $len + 258, $sv->IVX, $sv->NVX,
			    $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
    $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
			 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    $sv->save_magic;
    $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
		       $xpvbmsect->index, cstring($pv), $len),
	       sprintf("xpvbm_list[%d].xpv_cur = %u;",
		       $xpvbmsect->index, $len - 257));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
    $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
			 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
			   $xpvsect->index, cstring($pv), $len));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}