bytecode.pm

UNIX下perl实现代码

#      Bytecode.pm
#
#      Copyright (c) 1996-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::Bytecode;

use strict;
use Carp;
use B qw(main_cv main_root main_start comppadlist
	 class peekop walkoptree svref_2object cstring walksymtable
	 init_av begin_av end_av
	 SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
	 SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
	 GVf_IMPORTED_SV SVTYPEMASK
	);
use B::Asmdata qw(@optype @specialsv_name);
use B::Assembler qw(newasm endasm assemble);

my %optype_enum;
my $i;
for ($i = 0; $i < @optype; $i++) {
    $optype_enum{$optype[$i]} = $i;
}

# Following is SVf_POK|SVp_POK
# XXX Shouldn't be hardwired
sub POK () { SVf_POK|SVp_POK }

# Following is SVf_IOK|SVp_IOK
# XXX Shouldn't be hardwired
sub IOK () { SVf_IOK|SVp_IOK }

# Following is SVf_NOK|SVp_NOK
# XXX Shouldn't be hardwired
sub NOK () { SVf_NOK|SVp_NOK }

# nonexistant flags (see B::GV::bytecode for usage)
sub GVf_IMPORTED_IO () { 0; }
sub GVf_IMPORTED_FORM () { 0; }

my ($verbose, $no_assemble, $debug_bc, $debug_cv);
my @packages;	# list of packages to compile

sub asm (@) {	# print replacement that knows about assembling
    if ($no_assemble) {
	print @_;
    } else {
	my $buf = join '', @_;
	assemble($_) for (split /\n/, $buf);
    }
}

sub asmf (@) {	# printf replacement that knows about assembling
    if ($no_assemble) {
	printf shift(), @_;
    } else {
	my $format = shift;
	my $buf = sprintf $format, @_;
	assemble($_) for (split /\n/, $buf);
    }
}

# Optimisation options. On the command line, use hyphens instead of
# underscores for compatibility with gcc-style options. We use
# underscores here because they are OK in (strict) barewords.
my ($compress_nullops, $omit_seq, $bypass_nullops);
my %optimise = (compress_nullops	=> \$compress_nullops,
		omit_sequence_numbers	=> \$omit_seq,
		bypass_nullops		=> \$bypass_nullops);

my $strip_syntree;	# this is left here in case stripping the
			# syntree ever becomes safe again
			#	-- BKS, June 2000

my $nextix = 0;
my %symtable;	# maps object addresses to object indices.
		# Filled in at allocation (newsv/newop) time.

my %saved;	# maps object addresses (for SVish classes) to "saved yet?"
		# flag. Set at FOO::bytecode time usually by SV::bytecode.
		# Manipulated via saved(), mark_saved(), unmark_saved().

my %strtable;	# maps shared strings to object indices
		# Filled in at allocation (pvix) time

my $svix = -1;	# we keep track of when the sv register contains an element
		# of the object table to avoid unnecessary repeated
		# consecutive ldsv instructions.

my $opix = -1;	# Ditto for the op register.

sub ldsv {
    my $ix = shift;
    if ($ix != $svix) {
	asm "ldsv $ix\n";
	$svix = $ix;
    }
}

sub stsv {
    my $ix = shift;
    asm "stsv $ix\n";
    $svix = $ix;
}

sub set_svix {
    $svix = shift;
}

sub ldop {
    my $ix = shift;
    if ($ix != $opix) {
	asm "ldop $ix\n";
	$opix = $ix;
    }
}

sub stop {
    my $ix = shift;
    asm "stop $ix\n";
    $opix = $ix;
}

sub set_opix {
    $opix = shift;
}

sub pvstring {
    my $str = shift;
    if (defined($str)) {
	return cstring($str . "\0");
    } else {
	return '""';
    }
}

sub nv {
    # print full precision
    my $str = sprintf "%.40f", $_[0];
    $str =~ s/0+$//;		# remove trailing zeros
    $str =~ s/\.$/.0/;
    return $str;
}

sub saved { $saved{${$_[0]}} }
sub mark_saved { $saved{${$_[0]}} = 1 }
sub unmark_saved { $saved{${$_[0]}} = 0 }

sub debug { $debug_bc = shift }

sub pvix {	# save a shared PV (mainly for COPs)
    return $strtable{$_[0]} if defined($strtable{$_[0]});
    asmf "newpv %s\n", pvstring($_[0]);
    my $ix = $nextix++;
    $strtable{$_[0]} = $ix;
    asmf "stpv %d\n", $ix;
    return $ix;
}

sub B::OBJECT::nyi {
    my $obj = shift;
    warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
		 class($obj), $$obj);
}

#
# objix may stomp on the op register (for op objects)
# or the sv register (for SV objects)
#
sub B::OBJECT::objix {
    my $obj = shift;
    my $ix = $symtable{$$obj};
    if (defined($ix)) {
	return $ix;
    } else {
	$obj->newix($nextix);
	return $symtable{$$obj} = $nextix++;
    }
}

sub B::SV::newix {
    my ($sv, $ix) = @_;
    asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv);
    stsv($ix);    
}

sub B::GV::newix {
    my ($gv, $ix) = @_;
    my $gvname = $gv->NAME;
    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
    asm "gv_fetchpv $name\n";
    stsv($ix);
}

sub B::HV::newix {
    my ($hv, $ix) = @_;
    my $name = $hv->NAME;
    if ($name) {
	# It's a stash
	asmf "gv_stashpv %s\n", cstring($name);
	stsv($ix);
    } else {
	# It's an ordinary HV. Fall back to ordinary newix method
	$hv->B::SV::newix($ix);
    }
}

sub B::SPECIAL::newix {
    my ($sv, $ix) = @_;
    # Special case. $$sv is not the address of the SV but an
    # index into svspecialsv_list.
    asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
    stsv($ix);
}

sub B::OP::newix {
    my ($op, $ix) = @_;
    my $class = class($op);
    my $typenum = $optype_enum{$class};
    croak("OP::newix: can't understand class $class") unless defined($typenum);
    asm "newop $typenum\t# $class\n";
    stop($ix);
}

sub B::OP::walkoptree_debug {
    my $op = shift;
    warn(sprintf("walkoptree: %s\n", peekop($op)));
}

sub B::OP::bytecode {
    my $op = shift;
    my $next = $op->next;
    my $nextix;
    my $sibix = $op->sibling->objix unless $strip_syntree;
    my $ix = $op->objix;
    my $type = $op->type;

    if ($bypass_nullops) {
	$next = $next->next while $$next && $next->type == 0;
    }
    $nextix = $next->objix;

    asmf "# %s\n", peekop($op) if $debug_bc;
    ldop($ix);
    asm "op_next $nextix\n";
    asm "op_sibling $sibix\n" unless $strip_syntree;
    asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
    asmf("op_seq %d\n", $op->seq) unless $omit_seq;
    if ($type || !$compress_nullops) {
	asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
	    $op->targ, $op->flags, $op->private;
    }
}

sub B::UNOP::bytecode {
    my $op = shift;
    my $firstix = $op->first->objix unless $strip_syntree;
    $op->B::OP::bytecode;
    if (($op->type || !$compress_nullops) && !$strip_syntree) {
	asm "op_first $firstix\n";
    }
}

sub B::LOGOP::bytecode {
    my $op = shift;
    my $otherix = $op->other->objix;
    $op->B::UNOP::bytecode;
    asm "op_other $otherix\n";
}

sub B::SVOP::bytecode {
    my $op = shift;
    my $sv = $op->sv;
    my $svix = $sv->objix;
    $op->B::OP::bytecode;
    asm "op_sv $svix\n";
    $sv->bytecode;
}

sub B::PADOP::bytecode {
    my $op = shift;
    my $padix = $op->padix;
    $op->B::OP::bytecode;
    asm "op_padix $padix\n";
}

sub B::PVOP::bytecode {
    my $op = shift;
    my $pv = $op->pv;
    $op->B::OP::bytecode;
    #
    # This would be easy except that OP_TRANS uses a PVOP to store an
    # endian-dependent array of 256 shorts instead of a plain string.
    #
    if ($op->name eq "trans") {
	my @shorts = unpack("s256", $pv); # assembler handles endianness
	asm "op_pv_tr ", join(",", @shorts), "\n";
    } else {
	asmf "newpv %s\nop_pv\n", pvstring($pv);
    }
}

sub B::BINOP::bytecode {
    my $op = shift;
    my $lastix = $op->last->objix unless $strip_syntree;
    $op->B::UNOP::bytecode;
    if (($op->type || !$compress_nullops) && !$strip_syntree) {
	asm "op_last $lastix\n";
    }
}

sub B::LOOP::bytecode {
    my $op = shift;
    my $redoopix = $op->redoop->objix;
    my $nextopix = $op->nextop->objix;
    my $lastopix = $op->lastop->objix;
    $op->B::LISTOP::bytecode;
    asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
}

sub B::COP::bytecode {
    my $op = shift;
    my $file = $op->file;
    my $line = $op->line;
    if ($debug_bc) { # do this early to aid debugging
	asmf "# line %s:%d\n", $file, $line;
    }
    my $stashpv = $op->stashpv;
    my $warnings = $op->warnings;
    my $warningsix = $warnings->objix;
    my $labelix = pvix($op->label);
    my $stashix = pvix($stashpv);
    my $fileix = pvix($file);
    $warnings->bytecode;
    $op->B::OP::bytecode;
    asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase;
cop_label %d
cop_stashpv %d
cop_seq %d
cop_file %d
cop_arybase %d
cop_line $line
cop_warnings $warningsix
EOT
}

sub B::PMOP::bytecode {
    my $op = shift;
    my $replroot = $op->pmreplroot;
    my $replrootix = $replroot->objix;
    my $replstartix = $op->pmreplstart->objix;
    my $opname = $op->name;
    # pmnext is corrupt in some PMOPs (see misc.t for example)
    #my $pmnextix = $op->pmnext->objix;

    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 ($opname eq "pushre") {
	    $replroot->bytecode;
	} else {
	    walkoptree($replroot, "bytecode");
	}
    }
    $op->B::LISTOP::bytecode;
    if ($opname eq "pushre") {
	asmf "op_pmreplrootgv $replrootix\n";
    } else {
	asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
    }
    my $re = pvstring($op->precomp);
    # op_pmnext omitted since a perl bug means it's sometime corrupt
    asmf <<"EOT", $op->pmflags, $op->pmpermflags;
op_pmflags 0x%x
op_pmpermflags 0x%x
newpv $re
pregcomp
EOT
}

sub B::SV::bytecode {
    my $sv = shift;
    return if saved($sv);
    my $ix = $sv->objix;
    my $refcnt = $sv->REFCNT;
    my $flags = sprintf("0x%x", $sv->FLAGS);
    ldsv($ix);
    asm "sv_refcnt $refcnt\nsv_flags $flags\n";
    mark_saved($sv);
}

sub B::PV::bytecode {
    my $sv = shift;
    return if saved($sv);
    $sv->B::SV::bytecode;
    asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
}

sub B::IV::bytecode {
    my $sv = shift;
    return if saved($sv);
    my $iv = $sv->IVX;
    $sv->B::SV::bytecode;
    asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
}

sub B::NV::bytecode {
    my $sv = shift;
    return if saved($sv);
    $sv->B::SV::bytecode;
    asmf "xnv %s\n", nv($sv->NVX);
}

sub B::RV::bytecode {
    my $sv = shift;
    return if saved($sv);
    my $rv = $sv->RV;
    my $rvix = $rv->objix;
    $rv->bytecode;
    $sv->B::SV::bytecode;
    asm "xrv $rvix\n";
}

sub B::PVIV::bytecode {
    my $sv = shift;
    return if saved($sv);
    my $iv = $sv->IVX;
    $sv->B::PV::bytecode;
    asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
}

sub B::PVNV::bytecode {
    my $sv = shift;
    my $flag = shift || 0;
    # The $flag argument is passed through PVMG::bytecode by BM::bytecode
    # and AV::bytecode and indicates special handling. $flag = 1 is used by
    # BM::bytecode and means that we should ensure we save the whole B-M
    # table. It consists of 257 bytes (256 char array plus a final \0)
    # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
    # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
    # call SV::bytecode instead of saving PV and calling NV::bytecode since
    # PV/NV/IV stuff is different for AVs.
    return if saved($sv);
    if ($flag == 2) {
	$sv->B::SV::bytecode;
    } else {
	my $pv = $sv->PV;
	$sv->B::IV::bytecode;
	asmf "xnv %s\n", nv($sv->NVX);
	if ($flag == 1) {
	    $pv .= "\0" . $sv->TABLE;
	    asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
	} else {
	    asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
	}
    }
}

sub B::PVMG::bytecode {
    my ($sv, $flag) = @_;
    # See B::PVNV::bytecode for an explanation of $flag.
    return if saved($sv);
    # XXX We assume SvSTASH is already saved and don't save it later ourselves
    my $stashix = $sv->SvSTASH->objix;
    my @mgchain = $sv->MAGIC;
    my (@mgobjix, $mg);
    #
    # We need to traverse the magic chain and get objix for each OBJ
    # field *before* we do B::PVNV::bytecode since objix overwrites
    # the sv register. However, we need to write the magic-saving
    # bytecode *after* B::PVNV::bytecode since sv isn't initialised
    # to refer to $sv until then.
    #
    @mgobjix = map($_->OBJ->objix, @mgchain);
    $sv->B::PVNV::bytecode($flag);
    asm "xmg_stash $stashix\n";
    foreach $mg (@mgchain) {
	asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
	    cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
    }
}

sub B::PVLV::bytecode {
    my $sv = shift;
    return if saved($sv);
    $sv->B::PVMG::bytecode;
    asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
xlv_targoff %d
xlv_targlen %d
xlv_type %s
EOT
}

sub B::BM::bytecode {
    my $sv = shift;
    return if saved($sv);