# Nullsv *must* come first in the following so that the condition
# ($$sv == 0) can continue to be used to test (sv == Nullsv).
-my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
+my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
my (%alias_from, $from, $tos);
while (($from, $tos) = each %alias_to) {
#include "bytecode.h"
-static int optype_size[] = {
+static const int optype_size[] = {
EOT
my $i = 0;
for ($i = 0; $i < @optype - 1; $i++) {
print BYTERUN_C <<'EOT';
};
-static SV *specialsv_list[4];
-
static int bytecode_iv_overflows = 0;
-static SV *bytecode_sv;
-static XPV bytecode_pv;
-static void **bytecode_obj_list;
+static void **bytecode_obj_list = Null(void**);
static I32 bytecode_obj_list_fill = -1;
void *
{
if (ix > bytecode_obj_list_fill) {
if (bytecode_obj_list_fill == -1)
- New(666, bytecode_obj_list, ix + 1, void*);
+ New(666, bytecode_obj_list, ix + 32, void*);
else
- Renew(bytecode_obj_list, ix + 1, void*);
+ Renew(bytecode_obj_list, ix + 32, void*);
bytecode_obj_list_fill = ix;
}
bytecode_obj_list[ix] = obj;
}
void
-byterun(pTHXo_ struct bytestream bs)
+byterun(pTHXo)
{
dTHR;
int insn;
-
+ SV *bytecode_sv;
+ XPV bytecode_pv;
+ SV *specialsv_list[6];
+ ENTER;
+ SAVEVPTR(bytecode_obj_list);
+ SAVEI32(bytecode_obj_list_fill);
+ bytecode_obj_list = Null(void**);
+ bytecode_obj_list_fill = -1;
+
+ BYTECODE_HEADER_CHECK; /* croak if incorrect platform */
EOT
for (my $i = 0; $i < @specialsv; $i++) {
#
open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!";
print BYTERUN_H $c_header, <<'EOT';
-struct bytestream {
+struct bytestream { /* XXX: not currently used - too slow */
void *data;
int (*pfgetc)(void *);
int (*pfread)(char *, size_t, size_t, void *);
printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
print BYTERUN_H <<'EOT';
-extern void byterun(pTHXo_ struct bytestream bs);
-
-#define INIT_SPECIALSV_LIST STMT_START { \
-EOT
-for ($i = 0; $i < @specialsv; $i++) {
- print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n";
-}
-print BYTERUN_H <<'EOT';
- } STMT_END
+extern void byterun(pTHXo);
EOT
#
main_start PL_main_start opindex
main_root PL_main_root opindex
curpad PL_curpad svindex x
+push_begin PL_beginav svindex x
+push_init PL_initav svindex x
+push_end PL_endav svindex x
use Exporter;
use B qw(ppname);
use B::Asmdata qw(%insn_data @insn_name);
+use Config qw(%Config);
@ISA = qw(Exporter);
@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
- parse_statement uncstring);
+ parse_statement uncstring gen_header);
use strict;
my %opnumber;
return $c;
}
-sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
-sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_NV { sprintf("%lf\0", $_[0]) }
-sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
+sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
+sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
+sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
+ # may not even be portable between compilers
+sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
my $arg = shift;
$arg = uncstring($arg);
error "bad string argument: $arg" unless defined($arg);
- return pack("N", length($arg)) . $arg;
+ return pack("L", length($arg)) . $arg;
}
sub B::Asmdata::PUT_comment_t {
my $arg = shift;
}
return $arg . "\n";
}
-sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
sub B::Asmdata::PUT_none {
my $arg = shift;
error "extraneous argument: $arg" if defined $arg;
error "wrong number of arguments to op_tr_array";
@ary = (0) x 256;
}
- return pack("n256", @ary);
+ return pack("S256", @ary);
}
# XXX Check this works
sub B::Asmdata::PUT_IV64 {
my $arg = shift;
- return pack("NN", $arg >> 32, $arg & 0xffffffff);
+ return pack("LL", $arg >> 32, $arg & 0xffffffff);
}
my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
return $stmt;
}
+sub gen_header { # create the ByteCode header
+ my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
+ $header .= B::Asmdata::PUT_strconst($Config{archname});
+ $header .= B::Asmdata::PUT_U32($Config{ivsize});
+ $header .= B::Asmdata::PUT_U32($Config{nvsize});
+ $header .= B::Asmdata::PUT_U32($Config{ptrsize});
+ $header .= B::Asmdata::PUT_strconst($Config{byteorder}); # PV not U32 because
+ # of varying size
+ $header;
+}
sub parse_statement {
my $stmt = shift;
my ($insn, $arg) = $stmt =~ m{
my ($line, $insn, $arg);
$linenum = 0;
$errors = 0;
+ &$out(gen_header());
while ($line = <$fh>) {
$linenum++;
chomp $line;
#
package B::Bytecode;
use strict;
-use Carp;
use IO::File;
-use B qw(minus_c main_cv main_root main_start comppadlist
+use B qw(main_cv main_root main_start comppadlist
class peekop walkoptree svref_2object cstring walksymtable
- SVf_POK SVp_POK SVf_IOK SVp_IOK
+ 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
);
use B::Asmdata qw(@optype @specialsv_name);
use B::Assembler qw(assemble_fh);
# 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, $module_only, $no_assemble, $debug_bc, $debug_cv);
my $assembler_pid;
+my @packages; # list of packages to compile
# 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.
}
}
+sub nv {
+ # print full precision
+ my $str = sprintf "%.40f", $_[0];
+ return $str;
+}
sub saved { $saved{${$_[0]}} }
sub mark_saved { $saved{${$_[0]}} = 1 }
sub unmark_saved { $saved{${$_[0]}} = 0 }
my ($op, $ix) = @_;
my $class = class($op);
my $typenum = $optype_enum{$class};
- croak "OP::newix: can't understand class $class" unless defined($typenum);
+ require('Carp.pm'), Carp::croak("OP::newix: can't understand class $class")
+ unless defined($typenum);
print "newop $typenum\t# $class\n";
stop($ix);
}
my $op = shift;
my $next = $op->next;
my $nextix;
- my $sibix = $op->sibling->objix;
+ my $sibix = $op->sibling->objix unless $strip_syntree;
my $ix = $op->objix;
my $type = $op->type;
sub B::UNOP::bytecode {
my $op = shift;
- my $firstix = $op->first->objix;
+ my $firstix = $op->first->objix unless $strip_syntree;
$op->B::OP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
print "op_first $firstix\n";
sub B::BINOP::bytecode {
my $op = shift;
- my $lastix = $op->last->objix;
+ my $lastix = $op->last->objix unless $strip_syntree;
$op->B::UNOP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
print "op_last $lastix\n";
sub B::LISTOP::bytecode {
my $op = shift;
- my $children = $op->children;
+ my $children = $op->children unless $strip_syntree;
$op->B::BINOP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
print "op_children $children\n";
sub B::COP::bytecode {
my $op = shift;
- my $stashpv = $op->stashpv;
my $file = $op->file;
my $line = $op->line;
- my $warnings = $op->warnings;
- my $warningsix = $warnings->objix;
- if ($debug_bc) {
+ if ($debug_bc) { # do this early to aid debugging
printf "# line %s:%d\n", $file, $line;
}
+ my $stashpv = $op->stashpv;
+ my $warnings = $op->warnings;
+ my $warningsix;
+ $warningsix = $warnings->objix;
+ $warnings->bytecode;
$op->B::OP::bytecode;
printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
newpv %s
return if saved($sv);
my $iv = $sv->IVX;
$sv->B::SV::bytecode;
- printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+ printf "%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;
- printf "xnv %s\n", $sv->NVX;
+ printf "xnv %s\n", nv($sv->NVX);
}
sub B::RV::bytecode {
} else {
my $pv = $sv->PV;
$sv->B::IV::bytecode;
- printf "xnv %s\n", $sv->NVX;
+ printf "xnv %s\n", nv($sv->NVX);
if ($flag == 1) {
$pv .= "\0" . $sv->TABLE;
printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
sub B::GV::bytecode {
my $gv = shift;
return if saved($gv);
+ return unless grep { $_ eq $gv->STASH->NAME; } @packages;
my $ix = $gv->objix;
mark_saved($gv);
ldsv($ix);
if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
my $i;
my @subfield_names = qw(SV AV HV CV FORM IO);
+ @subfield_names = grep {;
+ no strict 'refs';
+ !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->());
+ } @subfield_names;
my @subfields = map($gv->$_(), @subfield_names);
my @ixes = map($_->objix, @subfields);
# Reset sv register for $gv
mark_saved($hv);
my $name = $hv->NAME;
my $ix = $hv->objix;
+ printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
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.
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;
}
}
# create an AV with NEWSV and SvUPGRADE rather than doing newAV
# which is what sets AvMAX and AvFILL.
ldsv($ix);
+ printf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
if ($fill > -1) {
my $elix;
print "av_extend $max\n";
}
}
+ printf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
}
sub B::CV::bytecode {
my $cv = shift;
return if saved($cv);
+ return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV);
my $ix = $cv->objix;
$cv->B::PVMG::bytecode;
my $i;
}
sub bytecompile_object {
- my $sv;
- foreach $sv (@_) {
+ for my $sv (@_) {
svref_2object($sv)->bytecode;
}
}
}
}
+sub save_call_queues {
+ if (ref(begin_av()) eq "B::AV") { # this is just to save 'use Foo;' calls
+ for my $cv (begin_av->ARRAY) {
+ my $name = $cv->STASH->NAME;
+ next unless grep { $_ eq $name } @packages;
+ my $op = $cv->START;
+ $op = $op->next while ($$op && ref $op ne "B::UNOP");
+ if ($$op && $op->name eq 'require') { # should be first UNOP
+ $cv->bytecode;
+ printf "push_begin %d\n", $cv->objix;
+ }
+ }
+ }
+ if (ref(init_av()) eq "B::AV") {
+ for my $cv (init_av->ARRAY) {
+ next unless grep { $_ eq $cv->STASH->NAME } @packages;
+ $cv->bytecode;
+ printf "push_init %d\n", $cv->objix;
+ }
+ }
+ if (ref(end_av()) eq "B::AV") {
+ for my $cv (end_av->ARRAY) {
+ next unless grep { $_ eq $cv->STASH->NAME } @packages;
+ $cv->bytecode;
+ printf "push_end %d\n", $cv->objix;
+ }
+ }
+}
+
+sub symwalk {
+ no strict 'refs';
+ my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
+ if (grep { /^$_[0]/; } @packages) {
+ walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
+ }
+ warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
+ if $debug_bc;
+ $ok;
+}
+
sub bytecompile_main {
my $curpad = (comppadlist->ARRAY)[1];
my $curpadix = $curpad->objix;
$curpad->bytecode;
- walkoptree(main_root, "bytecode");
+ walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
warn "done main program, now walking symbol table\n" if $debug_bc;
- my ($pack, %exclude);
- foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars
- FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings
- attributes File::Spec 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?
+ if (@packages) {
+ no strict qw(refs);
+ our %packages;
+ walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
+ } else {
+ die "No packages requested for compilation!\n";
}
+ save_call_queues;
+ 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 {
}
} elsif ($opt eq "v") {
$verbose = 1;
- } elsif ($opt eq "m") {
+ } elsif ($opt eq "m") { # XXX: NOP
$module_only = 1;
} elsif ($opt eq "S") {
$no_assemble = 1;
$compress_nullops = 1;
$omit_seq = 1;
}
+ } elsif ($opt eq "P") {
+ $arg ||= shift @options;
+ push @packages, $arg;
}
}
- if (@options) {
+ if (! @packages) {
+ warn "No package specified for compilation, assuming main::\n";
+ @packages = qw(main);
+ }
+ if (@options) { # XXX: unsupported and untested!
return sub {
my $objname;
my $newfh;
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.
-
+=item B<-Ppackage>
+
+Stores package in the output.
+
=back
=head1 EXAMPLES
- perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+ perl -MO=Bytecode,-O6,-ofoo.plc,-Pmain foo.pl
- perl -MO=Bytecode,-S foo.pl > foo.S
+ perl -MO=Bytecode,-S,-Pmain foo.pl > foo.S
assemble foo.S > foo.plc
Note that C<assemble> lives in the C<B> subdirectory of your perl
library directory. The utility called perlcc may also be used to
help make use of this compiler.
- perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+ perl -MO=Bytecode,-PFoo,-oFoo.pmc Foo.pm
=head1 BUGS
-Plenty. Current status: experimental.
+Output is still huge and there are still occasional crashes during
+either compilation or ByteLoading. Current status: experimental.
-=head1 AUTHOR
+=head1 AUTHORS
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Benjamin Stuhl, C<sho_pi@hotmail.com>
=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff