bytecode.pm

perl 解释器

}

sub B::BM::bytecode {
    my $sv = shift;
    return if saved($sv);
    # See PVNV::bytecode for an explanation of what the argument does
    $sv->B::PVMG::bytecode(1);
    printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
	$sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
}

sub B::GV::bytecode {
    my $gv = shift;
    return if saved($gv);
    my $ix = $gv->objix;
    mark_saved($gv);
    my $gvname = $gv->NAME;
    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
    my $egv = $gv->EGV;
    my $egvix = $egv->objix;
    ldsv($ix);
    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
sv_flags 0x%x
xgv_flags 0x%x
gp_line %d
EOT
    my $refcnt = $gv->REFCNT;
    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
    my $gvrefcnt = $gv->GvREFCNT;
    printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
    if ($gvrefcnt > 1 &&  $ix != $egvix) {
	print "gp_share $egvix\n";
    } else {
	if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
	    my $i;
	    my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
	    my @subfields = map($gv->$_(), @subfield_names);
	    my @ixes = map($_->objix, @subfields);
	    # Reset sv register for $gv
	    ldsv($ix);
	    for ($i = 0; $i < @ixes; $i++) {
		printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
	    }
	    # Now save all the subfields
	    my $sv;
	    foreach $sv (@subfields) {
		$sv->bytecode;
	    }
	}
    }
}

sub B::HV::bytecode {
    my $hv = shift;
    return if saved($hv);
    mark_saved($hv);
    my $name = $hv->NAME;
    my $ix = $hv->objix;
    if (!$name) {
	# It's an ordinary HV. Stashes have NAME set and need no further
	# saving beyond the gv_stashpv that $hv->objix already ensures.
	my @contents = $hv->ARRAY;
	my ($i, @ixes);
	for ($i = 1; $i < @contents; $i += 2) {
	    push(@ixes, $contents[$i]->objix);
	}
	for ($i = 1; $i < @contents; $i += 2) {
	    $contents[$i]->bytecode;
	}
	ldsv($ix);
	for ($i = 0; $i < @contents; $i += 2) {
	    printf("newpv %s\nhv_store %d\n",
		   pvstring($contents[$i]), $ixes[$i / 2]);
	}
	printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
    }
}

sub B::AV::bytecode {
    my $av = shift;
    return if saved($av);
    my $ix = $av->objix;
    my $fill = $av->FILL;
    my $max = $av->MAX;
    my (@array, @ixes);
    if ($fill > -1) {
	@array = $av->ARRAY;
	@ixes = map($_->objix, @array);
	my $sv;
	foreach $sv (@array) {
	    $sv->bytecode;
	}
    }
    # See PVNV::bytecode for the meaning of the flag argument of 2.
    $av->B::PVMG::bytecode(2);
    # Recover sv register and set AvMAX and AvFILL to -1 (since we
    # create an AV with NEWSV and SvUPGRADE rather than doing newAV
    # which is what sets AvMAX and AvFILL.
    ldsv($ix);
    printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
    if ($fill > -1) {
	my $elix;
	foreach $elix (@ixes) {
	    print "av_push $elix\n";
	}
    } else {
	if ($max > -1) {
	    print "av_extend $max\n";
	}
    }
}

sub B::CV::bytecode {
    my $cv = shift;
    return if saved($cv);
    my $ix = $cv->objix;
    $cv->B::PVMG::bytecode;
    my $i;
    my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
    my @subfields = map($cv->$_(), @subfield_names);
    my @ixes = map($_->objix, @subfields);
    # Save OP tree from CvROOT (first element of @subfields)
    my $root = shift @subfields;
    if ($$root) {
	walkoptree($root, "bytecode");
    }
    # Reset sv register for $cv (since above ->objix calls stomped on it)
    ldsv($ix);
    for ($i = 0; $i < @ixes; $i++) {
	printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
    }
    printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
    # Now save all the subfields (except for CvROOT which was handled
    # above) and CvSTART (now the initial element of @subfields).
    shift @subfields; # bye-bye CvSTART
    my $sv;
    foreach $sv (@subfields) {
	$sv->bytecode;
    }
}

sub B::IO::bytecode {
    my $io = shift;
    return if saved($io);
    my $ix = $io->objix;
    my $top_gv = $io->TOP_GV;
    my $top_gvix = $top_gv->objix;
    my $fmt_gv = $io->FMT_GV;
    my $fmt_gvix = $fmt_gv->objix;
    my $bottom_gv = $io->BOTTOM_GV;
    my $bottom_gvix = $bottom_gv->objix;

    $io->B::PVMG::bytecode;
    ldsv($ix);
    print "xio_top_gv $top_gvix\n";
    print "xio_fmt_gv $fmt_gvix\n";
    print "xio_bottom_gv $bottom_gvix\n";
    my $field;
    foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
	printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
    }
    foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
	printf "xio_%s %d\n", lc($field), $io->$field();
    }
    printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
    $top_gv->bytecode;
    $fmt_gv->bytecode;
    $bottom_gv->bytecode;
}

sub B::SPECIAL::bytecode {
    # nothing extra needs doing
}

sub bytecompile_object {
    my $sv;
    foreach $sv (@_) {
	svref_2object($sv)->bytecode;
    }
}

sub B::GV::bytecodecv {
    my $gv = shift;
    my $cv = $gv->CV;
    if ($$cv && !saved($cv)) {
	if ($debug_cv) {
	    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
			 $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
	}
	$gv->bytecode;
    }
}

sub bytecompile_main {
    my $curpad = (comppadlist->ARRAY)[1];
    my $curpadix = $curpad->objix;
    $curpad->bytecode;
    walkoptree(main_root, "bytecode");
    warn "done main program, now walking symbol table\n" if $debug_bc;
    my ($pack, %exclude);
    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
		      FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
		      SelectSaver blib Cwd))
    {
	$exclude{$pack."::"} = 1;
    }
    no strict qw(vars refs);
    walksymtable(\%{"main::"}, "bytecodecv", sub {
	warn "considering $_[0]\n" if $debug_bc;
	return !defined($exclude{$_[0]});
    });
    if (!$module_only) {
	printf "main_root %d\n", main_root->objix;
	printf "main_start %d\n", main_start->objix;
	printf "curpad $curpadix\n";
	# XXX Do min_intro_pending and max_intro_pending matter?
    }
}

sub prepare_assemble {
    my $newfh = IO::File->new_tmpfile;
    select($newfh);
    binmode $newfh;
    return $newfh;
}

sub do_assemble {
    my $fh = shift;
    seek($fh, 0, 0); # rewind the temporary file
    assemble_fh($fh, sub { print OUT @_ });
}

sub compile {
    my @options = @_;
    my ($option, $opt, $arg);
    open(OUT, ">&STDOUT");
    binmode OUT;
    select(OUT);
  OPTION:
    while ($option = shift @options) {
	if ($option =~ /^-(.)(.*)/) {
	    $opt = $1;
	    $arg = $2;
	} else {
	    unshift @options, $option;
	    last OPTION;
	}
	if ($opt eq "-" && $arg eq "-") {
	    shift @options;
	    last OPTION;
	} elsif ($opt eq "o") {
	    $arg ||= shift @options;
	    open(OUT, ">$arg") or return "$arg: $!\n";
	    binmode OUT;
	} elsif ($opt eq "D") {
	    $arg ||= shift @options;
	    foreach $arg (split(//, $arg)) {
		if ($arg eq "b") {
		    $| = 1;
		    debug(1);
		} elsif ($arg eq "o") {
		    B->debug(1);
		} elsif ($arg eq "a") {
		    B::Assembler::debug(1);
		} elsif ($arg eq "C") {
		    $debug_cv = 1;
		}
	    }
	} elsif ($opt eq "v") {
	    $verbose = 1;
	} elsif ($opt eq "m") {
	    $module_only = 1;
	} elsif ($opt eq "S") {
	    $no_assemble = 1;
	} elsif ($opt eq "f") {
	    $arg ||= shift @options;
	    my $value = $arg !~ s/^no-//;
	    $arg =~ s/-/_/g;
	    my $ref = $optimise{$arg};
	    if (defined($ref)) {
		$$ref = $value;
	    } else {
		warn qq(ignoring unknown optimisation option "$arg"\n);
	    }
	} elsif ($opt eq "O") {
	    $arg = 1 if $arg eq "";
	    my $ref;
	    foreach $ref (values %optimise) {
		$$ref = 0;
	    }
	    if ($arg >= 6) {
		$strip_syntree = 1;
	    }
	    if ($arg >= 2) {
		$bypass_nullops = 1;
	    }
	    if ($arg >= 1) {
		$compress_nullops = 1;
		$omit_seq = 1;
	    }
	}
    }
    if (@options) {
	return sub {
	    my $objname;
	    my $newfh; 
	    $newfh = prepare_assemble() unless $no_assemble;
	    foreach $objname (@options) {
		eval "bytecompile_object(\\$objname)";
	    }
	    do_assemble($newfh) unless $no_assemble;
	}
    } else {
	return sub {
	    my $newfh; 
	    $newfh = prepare_assemble() unless $no_assemble;
	    bytecompile_main();
	    do_assemble($newfh) unless $no_assemble;
	}
    }
}

1;

__END__

=head1 NAME

B::Bytecode - Perl compiler's bytecode backend

=head1 SYNOPSIS

	perl -MO=Bytecode[,OPTIONS] foo.pl

=head1 DESCRIPTION

This compiler backend takes Perl source and generates a
platform-independent bytecode encapsulating code to load the
internal structures perl uses to run your program. When the
generated bytecode is loaded in, your program is ready to run,
reducing 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
or may not be a help.

The resulting bytecode can be run with a special byteperl executable
or (for non-main programs) be loaded via the C<byteload_fh> function
in the F<B> module.

=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<-->

Force end of options.

=item B<-f>

Force optimisations on or off one at a time. Each can be preceded
by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).

=item B<-fcompress-nullops>

Only fills in the necessary fields of ops which have
been optimised away by perl's internal compiler.

=item B<-fomit-sequence-numbers>

Leaves out code to fill in the op_seq field of all ops
which is only used by perl's internal compiler.

=item B<-fbypass-nullops>

If op->op_next ever points to a NULLOP, replaces the op_next field
with the first non-NULLOP in the path of execution.

=item B<-fstrip-syntax-tree>

Leaves out code to fill in the pointers which link the internal syntax
tree together. They're not needed at run-time but leaving them out
will make it impossible to recompile or disassemble the resulting
program.  It will also stop C<goto label> statements from working.

=item B<-On>

Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
B<-O6> adds B<-fstrip-syntax-tree>.

=item B<-D>

Debug options (concatenated or separate flags like C<perl -D>).

=item B<-Do>

Prints each OP as it's processed.

=item B<-Db>

Print debugging information about bytecompiler progress.

=item B<-Da>

Tells the (bytecode) assembler to include source assembler lines
in its output as bytecode comments.

=item B<-DC>

Prints each CV taken from the final symbol tree walk.

=item B<-S>

Output (bytecode) assembler source rather than piping it
through the assembler and outputting bytecode.

=item B<-m>

Compile as a module rather than a standalone program. Currently this
just means that the bytecodes for initialising C<main_start>,
C<main_root> and C<curpad> are omitted.

=back

=head1 EXAMPLES

        perl -MO=Bytecode,-O6,-o,foo.plc foo.pl

        perl -MO=Bytecode,-S foo.pl > foo.S
        assemble foo.S > foo.plc
        byteperl foo.plc

        perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm

=head1 BUGS

Plenty. Current status: experimental.

=head1 AUTHOR

Malcolm Beattie, C<[e-mail]>

=cut