bytecode.pm

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 IO::File;

use B qw(minus_c main_cv main_root main_start comppadlist
	 class peekop walkoptree svref_2object cstring walksymtable);
use B::Asmdata qw(@optype @specialsv_name);
use B::Assembler qw(assemble_fh);

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 () { 0x04040000 }

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

my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
my $assembler_pid;

# 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 ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
my %optimise = (strip_syntax_tree	=> \$strip_syntree,
		compress_nullops	=> \$compress_nullops,
		omit_sequence_numbers	=> \$omit_seq,
		bypass_nullops		=> \$bypass_nullops);

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 $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) {
	print "ldsv $ix\n";
	$svix = $ix;
    }
}

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

sub set_svix {
    $svix = shift;
}

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

sub stop {
    my $ix = shift;
    print "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 saved { $saved{${$_[0]}} }
sub mark_saved { $saved{${$_[0]}} = 1 }
sub unmark_saved { $saved{${$_[0]}} = 0 }

sub debug { $debug_bc = shift }

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) = @_;
    printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
    stsv($ix);    
}

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

sub B::HV::newix {
    my ($hv, $ix) = @_;
    my $name = $hv->NAME;
    if ($name) {
	# It's a stash
	printf "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.
    printf "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);
    print "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;
    my $ix = $op->objix;
    my $type = $op->type;

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

    printf "# %s\n", peekop($op) if $debug_bc;
    ldop($ix);
    print "op_next $nextix\n";
    print "op_sibling $sibix\n" unless $strip_syntree;
    printf "op_type %s\t# %d\n", $op->ppaddr, $type;
    printf("op_seq %d\n", $op->seq) unless $omit_seq;
    if ($type || !$compress_nullops) {
	printf "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;
    $op->B::OP::bytecode;
    if (($op->type || !$compress_nullops) && !$strip_syntree) {
	print "op_first $firstix\n";
    }
}

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

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

sub B::GVOP::bytecode {
    my $op = shift;
    my $gv = $op->gv;
    my $gvix = $gv->objix;
    $op->B::OP::bytecode;
    print "op_gv $gvix\n";
    $gv->bytecode;
}

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->ppaddr eq "pp_trans") {
	my @shorts = unpack("s256", $pv); # assembler handles endianness
	print "op_pv_tr ", join(",", @shorts), "\n";
    } else {
	printf "newpv %s\nop_pv\n", pvstring($pv);
    }
}

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

sub B::CONDOP::bytecode {
    my $op = shift;
    my $trueix = $op->true->objix;
    my $falseix = $op->false->objix;
    $op->B::UNOP::bytecode;
    print "op_true $trueix\nop_false $falseix\n";
}

sub B::LISTOP::bytecode {
    my $op = shift;
    my $children = $op->children;
    $op->B::BINOP::bytecode;
    if (($op->type || !$compress_nullops) && !$strip_syntree) {
	print "op_children $children\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;
    print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
}

sub B::COP::bytecode {
    my $op = shift;
    my $stash = $op->stash;
    my $stashix = $stash->objix;
    my $filegv = $op->filegv;
    my $filegvix = $filegv->objix;
    my $line = $op->line;
    if ($debug_bc) {
	printf "# line %s:%d\n", $filegv->SV->PV, $line;
    }
    $op->B::OP::bytecode;
    printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
newpv %s
cop_label
cop_stash $stashix
cop_seq %d
cop_filegv $filegvix
cop_arybase %d
cop_line $line
EOT
    $filegv->bytecode;
    $stash->bytecode;
}

sub B::PMOP::bytecode {
    my $op = shift;
    my $replroot = $op->pmreplroot;
    my $replrootix = $replroot->objix;
    my $replstartix = $op->pmreplstart->objix;
    my $ppaddr = $op->ppaddr;
    # 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 ($ppaddr eq "pp_pushre") {
	    $replroot->bytecode;
	} else {
	    walkoptree($replroot, "bytecode");
	}
    }
    $op->B::LISTOP::bytecode;
    if ($ppaddr eq "pp_pushre") {
	printf "op_pmreplrootgv $replrootix\n";
    } else {
	print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
    }
    my $re = pvstring($op->precomp);
    # op_pmnext omitted since a perl bug means it's sometime corrupt
    printf <<"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);
    print "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;
    printf("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;
    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
}

sub B::NV::bytecode {
    my $sv = shift;
    return if saved($sv);
    $sv->B::SV::bytecode;
    printf "xnv %s\n", $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;
    print "xrv $rvix\n";
}

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

sub B::PVNV::bytecode {
    my ($sv, $flag) = @_;
    # 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;
	printf "xnv %s\n", $sv->NVX;
	if ($flag == 1) {
	    $pv .= "\0" . $sv->TABLE;
	    printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
	} else {
	    printf("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);
    print "xmg_stash $stashix\n";
    foreach $mg (@mgchain) {
	printf "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;
    printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
xlv_targoff %d
xlv_targlen %d
xlv_type %s
EOT