print BYTERUN_C <<'EOT';
};
-static int bytecode_iv_overflows = 0;
-static void **bytecode_obj_list = Null(void**);
-static I32 bytecode_obj_list_fill = -1;
-
void *
-bset_obj_store(pTHXo_ void *obj, I32 ix)
+bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix)
{
- if (ix > bytecode_obj_list_fill) {
- if (bytecode_obj_list_fill == -1)
- New(666, bytecode_obj_list, ix + 32, void*);
- else
- Renew(bytecode_obj_list, ix + 32, void*);
- bytecode_obj_list_fill = ix;
+ if (ix > bstate->bs_obj_list_fill) {
+ Renew(bstate->bs_obj_list, ix + 32, void*);
+ bstate->bs_obj_list_fill = ix + 31;
}
- bytecode_obj_list[ix] = obj;
+ bstate->bs_obj_list[ix] = obj;
return obj;
}
void
-byterun(pTHXo)
+byterun(pTHXo_ register struct byteloader_state *bstate)
{
dTHR;
- int insn;
- SV *bytecode_sv;
- XPV bytecode_pv;
+ register int insn;
+ U32 ix;
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 */
+ New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */
+ bstate->bs_obj_list_fill = 31;
+
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 { /* XXX: not currently used - too slow */
- void *data;
- int (*pfgetc)(void *);
- int (*pfread)(char *, size_t, size_t, void *);
- void (*pfreadpv)(U32, void *, XPV *);
+struct byteloader_fdata {
+ SV *datasv;
+ int next_out;
+ int idx;
+};
+
+struct byteloader_state {
+ struct byteloader_fdata *bs_fdata;
+ SV *bs_sv;
+ void **bs_obj_list;
+ int bs_obj_list_fill;
+ XPV bs_pv;
+ int bs_iv_overflows;
};
+int bl_getc(struct byteloader_fdata *);
+int bl_read(struct byteloader_fdata *, char *, size_t, size_t);
+extern void byterun(pTHXo_ struct byteloader_state *);
+
enum {
EOT
}
printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
-print BYTERUN_H <<'EOT';
-extern void byterun(pTHXo);
-EOT
-
#
# Finish off insn_data and create array initialisers in Asmdata.pm
#
#opcode lvalue argtype flags
#
ret none none x
-ldsv bytecode_sv svindex
+ldsv bstate->bs_sv svindex
ldop PL_op opindex
-stsv bytecode_sv U32 s
+stsv bstate->bs_sv U32 s
stop PL_op U32 s
-ldspecsv bytecode_sv U8 x
-newsv bytecode_sv U8 x
+stpv bstate->bs_pv.xpv_pv U32 x
+ldspecsv bstate->bs_sv U8 x
+newsv bstate->bs_sv U8 x
newop PL_op U8 x
newopn PL_op U8 x
newpv none PV
-pv_cur bytecode_pv.xpv_cur STRLEN
-pv_free bytecode_pv none x
-sv_upgrade bytecode_sv char x
-sv_refcnt SvREFCNT(bytecode_sv) U32
-sv_refcnt_add SvREFCNT(bytecode_sv) I32 x
-sv_flags SvFLAGS(bytecode_sv) U32
-xrv SvRV(bytecode_sv) svindex
-xpv bytecode_sv none x
-xiv32 SvIVX(bytecode_sv) I32
-xiv64 SvIVX(bytecode_sv) IV64
-xnv SvNVX(bytecode_sv) NV
-xlv_targoff LvTARGOFF(bytecode_sv) STRLEN
-xlv_targlen LvTARGLEN(bytecode_sv) STRLEN
-xlv_targ LvTARG(bytecode_sv) svindex
-xlv_type LvTYPE(bytecode_sv) char
-xbm_useful BmUSEFUL(bytecode_sv) I32
-xbm_previous BmPREVIOUS(bytecode_sv) U16
-xbm_rare BmRARE(bytecode_sv) U8
-xfm_lines FmLINES(bytecode_sv) I32
-xio_lines IoLINES(bytecode_sv) long
-xio_page IoPAGE(bytecode_sv) long
-xio_page_len IoPAGE_LEN(bytecode_sv) long
-xio_lines_left IoLINES_LEFT(bytecode_sv) long
-xio_top_name IoTOP_NAME(bytecode_sv) pvcontents
-xio_top_gv *(SV**)&IoTOP_GV(bytecode_sv) svindex
-xio_fmt_name IoFMT_NAME(bytecode_sv) pvcontents
-xio_fmt_gv *(SV**)&IoFMT_GV(bytecode_sv) svindex
-xio_bottom_name IoBOTTOM_NAME(bytecode_sv) pvcontents
-xio_bottom_gv *(SV**)&IoBOTTOM_GV(bytecode_sv) svindex
-xio_subprocess IoSUBPROCESS(bytecode_sv) short
-xio_type IoTYPE(bytecode_sv) char
-xio_flags IoFLAGS(bytecode_sv) char
-xcv_stash *(SV**)&CvSTASH(bytecode_sv) svindex
-xcv_start CvSTART(bytecode_sv) opindex
-xcv_root CvROOT(bytecode_sv) opindex
-xcv_gv *(SV**)&CvGV(bytecode_sv) svindex
-xcv_file CvFILE(bytecode_sv) pvcontents
-xcv_depth CvDEPTH(bytecode_sv) long
-xcv_padlist *(SV**)&CvPADLIST(bytecode_sv) svindex
-xcv_outside *(SV**)&CvOUTSIDE(bytecode_sv) svindex
-xcv_flags CvFLAGS(bytecode_sv) U16
-av_extend bytecode_sv SSize_t x
-av_push bytecode_sv svindex x
-xav_fill AvFILLp(bytecode_sv) SSize_t
-xav_max AvMAX(bytecode_sv) SSize_t
-xav_flags AvFLAGS(bytecode_sv) U8
-xhv_riter HvRITER(bytecode_sv) I32
-xhv_name HvNAME(bytecode_sv) pvcontents
-hv_store bytecode_sv svindex x
-sv_magic bytecode_sv char x
-mg_obj SvMAGIC(bytecode_sv)->mg_obj svindex
-mg_private SvMAGIC(bytecode_sv)->mg_private U16
-mg_flags SvMAGIC(bytecode_sv)->mg_flags U8
-mg_pv SvMAGIC(bytecode_sv) pvcontents x
-xmg_stash *(SV**)&SvSTASH(bytecode_sv) svindex
-gv_fetchpv bytecode_sv strconst x
-gv_stashpv bytecode_sv strconst x
-gp_sv GvSV(bytecode_sv) svindex
-gp_refcnt GvREFCNT(bytecode_sv) U32
-gp_refcnt_add GvREFCNT(bytecode_sv) I32 x
-gp_av *(SV**)&GvAV(bytecode_sv) svindex
-gp_hv *(SV**)&GvHV(bytecode_sv) svindex
-gp_cv *(SV**)&GvCV(bytecode_sv) svindex
-gp_file GvFILE(bytecode_sv) pvcontents
-gp_io *(SV**)&GvIOp(bytecode_sv) svindex
-gp_form *(SV**)&GvFORM(bytecode_sv) svindex
-gp_cvgen GvCVGEN(bytecode_sv) U32
-gp_line GvLINE(bytecode_sv) line_t
-gp_share bytecode_sv svindex x
-xgv_flags GvFLAGS(bytecode_sv) U8
+pv_cur bstate->bs_pv.xpv_cur STRLEN
+pv_free bstate->bs_pv none x
+sv_upgrade bstate->bs_sv char x
+sv_refcnt SvREFCNT(bstate->bs_sv) U32
+sv_refcnt_add SvREFCNT(bstate->bs_sv) I32 x
+sv_flags SvFLAGS(bstate->bs_sv) U32
+xrv SvRV(bstate->bs_sv) svindex
+xpv bstate->bs_sv none x
+xiv32 SvIVX(bstate->bs_sv) I32
+xiv64 SvIVX(bstate->bs_sv) IV64
+xnv SvNVX(bstate->bs_sv) NV
+xlv_targoff LvTARGOFF(bstate->bs_sv) STRLEN
+xlv_targlen LvTARGLEN(bstate->bs_sv) STRLEN
+xlv_targ LvTARG(bstate->bs_sv) svindex
+xlv_type LvTYPE(bstate->bs_sv) char
+xbm_useful BmUSEFUL(bstate->bs_sv) I32
+xbm_previous BmPREVIOUS(bstate->bs_sv) U16
+xbm_rare BmRARE(bstate->bs_sv) U8
+xfm_lines FmLINES(bstate->bs_sv) I32
+xio_lines IoLINES(bstate->bs_sv) long
+xio_page IoPAGE(bstate->bs_sv) long
+xio_page_len IoPAGE_LEN(bstate->bs_sv) long
+xio_lines_left IoLINES_LEFT(bstate->bs_sv) long
+xio_top_name IoTOP_NAME(bstate->bs_sv) pvcontents
+xio_top_gv *(SV**)&IoTOP_GV(bstate->bs_sv) svindex
+xio_fmt_name IoFMT_NAME(bstate->bs_sv) pvcontents
+xio_fmt_gv *(SV**)&IoFMT_GV(bstate->bs_sv) svindex
+xio_bottom_name IoBOTTOM_NAME(bstate->bs_sv) pvcontents
+xio_bottom_gv *(SV**)&IoBOTTOM_GV(bstate->bs_sv) svindex
+xio_subprocess IoSUBPROCESS(bstate->bs_sv) short
+xio_type IoTYPE(bstate->bs_sv) char
+xio_flags IoFLAGS(bstate->bs_sv) char
+xcv_stash *(SV**)&CvSTASH(bstate->bs_sv) svindex
+xcv_start CvSTART(bstate->bs_sv) opindex
+xcv_root CvROOT(bstate->bs_sv) opindex
+xcv_gv *(SV**)&CvGV(bstate->bs_sv) svindex
+xcv_file CvFILE(bstate->bs_sv) pvindex
+xcv_depth CvDEPTH(bstate->bs_sv) long
+xcv_padlist *(SV**)&CvPADLIST(bstate->bs_sv) svindex
+xcv_outside *(SV**)&CvOUTSIDE(bstate->bs_sv) svindex
+xcv_flags CvFLAGS(bstate->bs_sv) U16
+av_extend bstate->bs_sv SSize_t x
+av_push bstate->bs_sv svindex x
+xav_fill AvFILLp(bstate->bs_sv) SSize_t
+xav_max AvMAX(bstate->bs_sv) SSize_t
+xav_flags AvFLAGS(bstate->bs_sv) U8
+xhv_riter HvRITER(bstate->bs_sv) I32
+xhv_name HvNAME(bstate->bs_sv) pvcontents
+hv_store bstate->bs_sv svindex x
+sv_magic bstate->bs_sv char x
+mg_obj SvMAGIC(bstate->bs_sv)->mg_obj svindex
+mg_private SvMAGIC(bstate->bs_sv)->mg_private U16
+mg_flags SvMAGIC(bstate->bs_sv)->mg_flags U8
+mg_pv SvMAGIC(bstate->bs_sv) pvcontents x
+xmg_stash *(SV**)&SvSTASH(bstate->bs_sv) svindex
+gv_fetchpv bstate->bs_sv strconst x
+gv_stashpv bstate->bs_sv strconst x
+gp_sv GvSV(bstate->bs_sv) svindex
+gp_refcnt GvREFCNT(bstate->bs_sv) U32
+gp_refcnt_add GvREFCNT(bstate->bs_sv) I32 x
+gp_av *(SV**)&GvAV(bstate->bs_sv) svindex
+gp_hv *(SV**)&GvHV(bstate->bs_sv) svindex
+gp_cv *(SV**)&GvCV(bstate->bs_sv) svindex
+gp_file GvFILE(bstate->bs_sv) pvindex
+gp_io *(SV**)&GvIOp(bstate->bs_sv) svindex
+gp_form *(SV**)&GvFORM(bstate->bs_sv) svindex
+gp_cvgen GvCVGEN(bstate->bs_sv) U32
+gp_line GvLINE(bstate->bs_sv) line_t
+gp_share bstate->bs_sv svindex x
+xgv_flags GvFLAGS(bstate->bs_sv) U8
op_next PL_op->op_next opindex
op_sibling PL_op->op_sibling opindex
op_ppaddr PL_op->op_ppaddr strconst x
op_redoop cLOOP->op_redoop opindex
op_nextop cLOOP->op_nextop opindex
op_lastop cLOOP->op_lastop opindex
-cop_label cCOP->cop_label pvcontents
-cop_stashpv cCOP pvcontents x
-cop_file cCOP pvcontents x
+cop_label cCOP->cop_label pvindex
+cop_stashpv cCOP pvindex x
+cop_file cCOP pvindex x
cop_seq cCOP->cop_seq U32
cop_arybase cCOP->cop_arybase I32
cop_line cCOP line_t x
#
# 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::Assembler;
use Exporter;
use B qw(ppname);
use B::Asmdata qw(%insn_data @insn_name);
use Config qw(%Config);
+require ByteLoader; # we just need its $VERSIOM
@ISA = qw(Exporter);
-@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
- parse_statement uncstring gen_header);
+@EXPORT_OK = qw(assemble_fh newasm endasm assemble);
+$VERSION = 0.02;
use strict;
my %opnumber;
$opnumber{$opname} = $i;
}
-my ($linenum, $errors);
+my($linenum, $errors, $out); # global state, set up by newasm
sub error {
my $str = shift;
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 }
+sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_strconst {
my $arg = shift;
return $stmt;
}
-sub gen_header { # create the ByteCode header: magic, archname, ivsize, ptrsize,
- # byteorder
- # nvtype irrelevant (floats are stored as strings)
- my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
- $header .= B::Asmdata::PUT_strconst(qq["$Config{archname}"]);
+# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
+# ptrsize, byteorder
+# nvtype is irrelevant (floats are stored as strings)
+# byteorder is strconst not U32 because of varying size issues
+
+sub gen_header {
+ my $header = "";
+
+ $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
+ $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
+ $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
$header .= B::Asmdata::PUT_U32($Config{ivsize});
$header .= B::Asmdata::PUT_U32($Config{ptrsize});
$header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
- # PV not U32 because
- # of varying size
$header;
}
sub assemble_fh {
my ($fh, $out) = @_;
- my ($line, $insn, $arg);
- $linenum = 0;
- $errors = 0;
- &$out(gen_header());
+ my $line;
+ my $asm = newasm($out);
while ($line = <$fh>) {
- $linenum++;
- chomp $line;
- if ($debug) {
- my $quotedline = $line;
- $quotedline =~ s/\\/\\\\/g;
- $quotedline =~ s/"/\\"/g;
- &$out(assemble_insn("comment", qq("$quotedline")));
- }
- $line = strip_comments($line) or next;
- ($insn, $arg) = parse_statement($line);
- &$out(assemble_insn($insn, $arg));
- if ($debug) {
- &$out(assemble_insn("nop", undef));
- }
+ assemble($line);
}
+ endasm();
+}
+
+sub newasm {
+ my($outsub) = @_;
+
+ die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
+ die <<EOD if ref $out;
+Can't have multiple byteassembly sessions at once!
+ (perhaps you forgot an endasm()?)
+EOD
+
+ $linenum = $errors = 0;
+ $out = $outsub;
+
+ $out->(gen_header());
+}
+
+sub endasm {
if ($errors) {
- die "Assembly failed with $errors error(s)\n";
+ die "There were $errors assembly errors\n";
+ }
+ $linenum = $errors = $out = 0;
+}
+
+sub assemble {
+ my($line) = @_;
+ my ($insn, $arg);
+ $linenum++;
+ chomp $line;
+ if ($debug) {
+ my $quotedline = $line;
+ $quotedline =~ s/\\/\\\\/g;
+ $quotedline =~ s/"/\\"/g;
+ $out->(assemble_insn("comment", qq("$quotedline")));
+ }
+ $line = strip_comments($line) or next;
+ ($insn, $arg) = parse_statement($line);
+ $out->(assemble_insn($insn, $arg));
+ if ($debug) {
+ $out->(assemble_insn("nop", undef));
}
}
=head1 SYNOPSIS
- use Assembler;
+ use B::Assembler qw(newasm endasm assemble);
+ newasm(\&printsub); # sets up for assembly
+ assemble($buf); # assembles one line
+ endasm(); # closes down
+
+ use B::Assembler qw(assemble_fh);
+ assemble_fh($fh, \&printsub); # assemble everything in $fh
=head1 DESCRIPTION
See F<ext/B/B/Assembler.pm>.
-=head1 AUTHOR
+=head1 AUTHORS
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
=cut
# License or the Artistic License, as specified in the README file.
#
package B::Bytecode;
-use strict;
-use IO::File;
+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
+ GVf_IMPORTED_SV SVTYPEMASK
);
use B::Asmdata qw(@optype @specialsv_name);
-use B::Assembler qw(assemble_fh);
+use B::Assembler qw(newasm endasm assemble);
my %optype_enum;
my $i;
# 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 ($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 ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
-my %optimise = (strip_syntax_tree => \$strip_syntree,
- compress_nullops => \$compress_nullops,
+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) {
- print "ldsv $ix\n";
+ asm "ldsv $ix\n";
$svix = $ix;
}
}
sub stsv {
my $ix = shift;
- print "stsv $ix\n";
+ asm "stsv $ix\n";
$svix = $ix;
}
sub ldop {
my $ix = shift;
if ($ix != $opix) {
- print "ldop $ix\n";
+ asm "ldop $ix\n";
$opix = $ix;
}
}
sub stop {
my $ix = shift;
- print "stop $ix\n";
+ asm "stop $ix\n";
$opix = $ix;
}
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",
sub B::SV::newix {
my ($sv, $ix) = @_;
- printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
+ asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv);
stsv($ix);
}
my ($gv, $ix) = @_;
my $gvname = $gv->NAME;
my $name = cstring($gv->STASH->NAME . "::" . $gvname);
- print "gv_fetchpv $name\n";
+ asm "gv_fetchpv $name\n";
stsv($ix);
}
my $name = $hv->NAME;
if ($name) {
# It's a stash
- printf "gv_stashpv %s\n", cstring($name);
+ asmf "gv_stashpv %s\n", cstring($name);
stsv($ix);
} else {
# It's an ordinary HV. Fall back to ordinary newix method
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];
+ asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
stsv($ix);
}
my ($op, $ix) = @_;
my $class = class($op);
my $typenum = $optype_enum{$class};
- require('Carp.pm'), Carp::croak("OP::newix: can't understand class $class")
- unless defined($typenum);
- print "newop $typenum\t# $class\n";
+ croak("OP::newix: can't understand class $class") unless defined($typenum);
+ asm "newop $typenum\t# $class\n";
stop($ix);
}
}
$nextix = $next->objix;
- printf "# %s\n", peekop($op) if $debug_bc;
+ asmf "# %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", "pp_" . $op->name, $type;
- printf("op_seq %d\n", $op->seq) unless $omit_seq;
+ 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) {
- printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
+ asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
$op->targ, $op->flags, $op->private;
}
}
my $firstix = $op->first->objix unless $strip_syntree;
$op->B::OP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
- print "op_first $firstix\n";
+ asm "op_first $firstix\n";
}
}
my $op = shift;
my $otherix = $op->other->objix;
$op->B::UNOP::bytecode;
- print "op_other $otherix\n";
+ asm "op_other $otherix\n";
}
sub B::SVOP::bytecode {
my $sv = $op->sv;
my $svix = $sv->objix;
$op->B::OP::bytecode;
- print "op_sv $svix\n";
+ asm "op_sv $svix\n";
$sv->bytecode;
}
my $op = shift;
my $padix = $op->padix;
$op->B::OP::bytecode;
- print "op_padix $padix\n";
+ asm "op_padix $padix\n";
}
sub B::PVOP::bytecode {
#
if ($op->name eq "trans") {
my @shorts = unpack("s256", $pv); # assembler handles endianness
- print "op_pv_tr ", join(",", @shorts), "\n";
+ asm "op_pv_tr ", join(",", @shorts), "\n";
} else {
- printf "newpv %s\nop_pv\n", pvstring($pv);
+ asmf "newpv %s\nop_pv\n", pvstring($pv);
}
}
my $lastix = $op->last->objix unless $strip_syntree;
$op->B::UNOP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
- print "op_last $lastix\n";
+ asm "op_last $lastix\n";
}
}
my $children = $op->children unless $strip_syntree;
$op->B::BINOP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
- print "op_children $children\n";
+ asm "op_children $children\n";
}
}
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";
+ asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
}
sub B::COP::bytecode {
my $file = $op->file;
my $line = $op->line;
if ($debug_bc) { # do this early to aid debugging
- printf "# line %s:%d\n", $file, $line;
+ 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;
- printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
-newpv %s
-cop_label
-newpv %s
-cop_stashpv
+ asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase;
+cop_label %d
+cop_stashpv %d
cop_seq %d
-newpv %s
-cop_file
+cop_file %d
cop_arybase %d
cop_line $line
cop_warnings $warningsix
}
$op->B::LISTOP::bytecode;
if ($opname eq "pushre") {
- printf "op_pmreplrootgv $replrootix\n";
+ asmf "op_pmreplrootgv $replrootix\n";
} else {
- print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+ 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
- printf <<"EOT", $op->pmflags, $op->pmpermflags;
+ asmf <<"EOT", $op->pmflags, $op->pmpermflags;
op_pmflags 0x%x
op_pmpermflags 0x%x
newpv $re
my $refcnt = $sv->REFCNT;
my $flags = sprintf("0x%x", $sv->FLAGS);
ldsv($ix);
- print "sv_refcnt $refcnt\nsv_flags $flags\n";
+ asm "sv_refcnt $refcnt\nsv_flags $flags\n";
mark_saved($sv);
}
my $sv = shift;
return if saved($sv);
$sv->B::SV::bytecode;
- printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
+ asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
}
sub B::IV::bytecode {
return if saved($sv);
my $iv = $sv->IVX;
$sv->B::SV::bytecode;
- printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
+ 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;
- printf "xnv %s\n", nv($sv->NVX);
+ asmf "xnv %s\n", nv($sv->NVX);
}
sub B::RV::bytecode {
my $rvix = $rv->objix;
$rv->bytecode;
$sv->B::SV::bytecode;
- print "xrv $rvix\n";
+ asm "xrv $rvix\n";
}
sub B::PVIV::bytecode {
return if saved($sv);
my $iv = $sv->IVX;
$sv->B::PV::bytecode;
- printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+ asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
}
sub B::PVNV::bytecode {
} else {
my $pv = $sv->PV;
$sv->B::IV::bytecode;
- printf "xnv %s\n", nv($sv->NVX);
+ asmf "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;
+ asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
} else {
- printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
+ asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
}
}
}
#
@mgobjix = map($_->OBJ->objix, @mgchain);
$sv->B::PVNV::bytecode($flag);
- print "xmg_stash $stashix\n";
+ asm "xmg_stash $stashix\n";
foreach $mg (@mgchain) {
- printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
+ asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
}
}
my $sv = shift;
return if saved($sv);
$sv->B::PVMG::bytecode;
- printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
+ asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
xlv_targoff %d
xlv_targlen %d
xlv_type %s
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",
+ asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
$sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
}
+sub empty_gv { # is a GV empty except for imported stuff?
+ my $gv = shift;
+
+ return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL
+ my @subfield_names = qw(AV HV CV FORM IO);
+ @subfield_names = grep {;
+ no strict 'refs';
+ !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()};
+ } @subfield_names;
+ return scalar @subfield_names;
+}
+
sub B::GV::bytecode {
my $gv = shift;
return if saved($gv);
return unless grep { $_ eq $gv->STASH->NAME; } @packages;
+ return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt
my $ix = $gv->objix;
mark_saved($gv);
ldsv($ix);
- printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
+ asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
sv_flags 0x%x
xgv_flags 0x%x
EOT
my $refcnt = $gv->REFCNT;
- printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
+ asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
return if $gv->is_empty;
- printf <<"EOT", $gv->LINE, pvstring($gv->FILE);
+ asmf <<"EOT", $gv->LINE, pvix($gv->FILE);
gp_line %d
-newpv %s
-gp_file
+gp_file %d
EOT
my $gvname = $gv->NAME;
my $name = cstring($gv->STASH->NAME . "::" . $gvname);
my $egv = $gv->EGV;
my $egvix = $egv->objix;
my $gvrefcnt = $gv->GvREFCNT;
- printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
+ asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
if ($gvrefcnt > 1 && $ix != $egvix) {
- print "gp_share $egvix\n";
+ asm "gp_share $egvix\n";
} else {
if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
my $i;
# Reset sv register for $gv
ldsv($ix);
for ($i = 0; $i < @ixes; $i++) {
- printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
+ asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
}
# Now save all the subfields
my $sv;
}
ldsv($ix);
for ($i = 0; $i < @contents; $i += 2) {
- printf("newpv %s\nhv_store %d\n",
+ asmf("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;
+ asmf "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;
+ asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
+ asmf "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";
+ asm "av_push $elix\n";
}
} else {
if ($max > -1) {
- print "av_extend $max\n";
+ asm "av_extend $max\n";
}
}
- printf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
+ asmf "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 $fileix = pvix($cv->FILE);
my $ix = $cv->objix;
$cv->B::PVMG::bytecode;
my $i;
# 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];
+ asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
}
- printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
- printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
+ asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
+ asmf "xcv_file %d\n", $fileix;
# 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
$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";
+ asm "xio_top_gv $top_gvix\n";
+ asm "xio_fmt_gv $fmt_gvix\n";
+ asm "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);
+ asmf "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();
+ asmf "xio_%s %d\n", lc($field), $io->$field();
}
- printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
+ asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
$top_gv->bytecode;
$fmt_gv->bytecode;
$bottom_gv->bytecode;
sub B::GV::bytecodecv {
my $gv = shift;
my $cv = $gv->CV;
- if ($$cv && !saved($cv)) {
+ if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_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);
}
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;
+ if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls
+ for my $cv (begin_av()->ARRAY) {
+ next unless grep { $_ eq $cv->STASH->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;
+OPLOOP:
+ while ($$op) {
+ if ($op->name eq 'require') { # save any BEGIN that does a require
+ $cv->bytecode;
+ asmf "push_begin %d\n", $cv->objix;
+ last OPLOOP;
+ }
+ $op = $op->next;
}
}
}
- if (ref(init_av()) eq "B::AV") {
- for my $cv (init_av->ARRAY) {
- next unless grep { $_ eq $cv->STASH->NAME } @packages;
+ if (init_av()->isa("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;
+ asmf "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;
+ if (end_av()->isa("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;
+ asmf "push_end %d\n", $cv->objix;
}
}
}
sub symwalk {
- no strict 'refs';
- my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
+ no strict 'refs';
+ my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
if (grep { /^$_[0]/; } @packages) {
walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
}
my $curpad = (comppadlist->ARRAY)[1];
my $curpadix = $curpad->objix;
$curpad->bytecode;
+ save_call_queues();
walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
warn "done main program, now walking symbol table\n" if $debug_bc;
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";
+ asmf "main_root %d\n", main_root->objix;
+ asmf "main_start %d\n", main_start->objix;
+ asmf "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);
+ select OUT;
OPTION:
while ($option = shift @options) {
if ($option =~ /^-(.)(.*)/) {
}
} elsif ($opt eq "v") {
$verbose = 1;
- } elsif ($opt eq "m") { # XXX: NOP
- $module_only = 1;
} elsif ($opt eq "S") {
$no_assemble = 1;
} elsif ($opt eq "f") {
foreach $ref (values %optimise) {
$$ref = 0;
}
- if ($arg >= 6) {
- $strip_syntree = 1;
- }
if ($arg >= 2) {
$bypass_nullops = 1;
}
} elsif ($opt eq "P") {
$arg ||= shift @options;
push @packages, $arg;
+ } else {
+ warn qq(ignoring unknown option "$opt$arg"\n);
}
}
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;
- $newfh = prepare_assemble() unless $no_assemble;
- foreach $objname (@options) {
- eval "bytecompile_object(\\$objname)";
- }
- do_assemble($newfh) unless $no_assemble;
- }
+ if (@options) {
+ die "Extraneous options left on B::Bytecode commandline: @options\n";
} else {
- return sub {
- my $newfh;
- $newfh = prepare_assemble() unless $no_assemble;
+ return sub {
+ newasm(\&apr) unless $no_assemble;
bytecompile_main();
- do_assemble($newfh) unless $no_assemble;
- }
+ endasm() unless $no_assemble;
+ };
}
}
+sub apr { print @_; }
+
1;
__END__
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>.
+B<-O2> adds B<-fbypass-nullops>.
=item B<-D>
package O;
-use B qw(minus_c);
+use B qw(minus_c save_BEGINs);
use Carp;
sub import {
open(OUT,">$out") || die "Cannot open $file:$!";
print "Extracting $out...\n";
foreach my $const (qw(AVf_REAL
- HEf_SVKEY SVphv_SHAREKEYS
- SVf_READONLY
+ HEf_SVKEY
+ SVf_READONLY SVTYPEMASK
GVf_IMPORTED_AV GVf_IMPORTED_HV
GVf_IMPORTED_SV GVf_IMPORTED_CV
SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
use XSLoader ();
-$VERSION = 0.03;
+$VERSION = 0.04;
XSLoader::load 'ByteLoader', $VERSION;
=head1 SYNOPSIS
- use ByteLoader 0.03;
+ use ByteLoader 0.04;
<byte code>
- use ByteLoader 0.03;
+ use ByteLoader 0.04;
<byte code>
=head1 DESCRIPTION
#include "XSUB.h"
#include "byterun.h"
+/* Something arbitary for a buffer size */
+#define BYTELOADER_BUFFER 8096
+
+int
+bl_getc(struct byteloader_fdata *data)
+{
+ dTHX;
+ if (SvCUR(data->datasv) <= data->next_out) {
+ int result;
+ /* Run out of buffered data, so attempt to read some more */
+ *(SvPV_nolen (data->datasv)) = '\0';
+ SvCUR_set (data->datasv, 0);
+ data->next_out = 0;
+ result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER);
+
+ /* Filter returned error, or we got EOF and no data, then return EOF.
+ Not sure if filter is allowed to return EOF and add data simultaneously
+ Think not, but will bullet proof against it. */
+ if (result < 0 || SvCUR(data->datasv) == 0)
+ return EOF;
+ /* Else there must be at least one byte present, which is good enough */
+ }
+
+ return *((char *) SvPV_nolen (data->datasv) + data->next_out++);
+}
+
+int
+bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n)
+{
+ dTHX;
+ char *start;
+ STRLEN len;
+ size_t wanted = size * n;
+
+ start = SvPV (data->datasv, len);
+ if (len < (data->next_out + wanted)) {
+ int result;
+
+ /* Shuffle data to start of buffer */
+ len -= data->next_out;
+ if (len) {
+ memmove (start, start + data->next_out, len + 1);
+ SvCUR_set (data->datasv, len);
+ } else {
+ *start = '\0'; /* Avoid call to memmove. */
+ SvCUR_set (data->datasv, 0);
+ }
+ data->next_out = 0;
+
+ /* Attempt to read more data. */
+ do {
+ result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER);
+
+ start = SvPV (data->datasv, len);
+ } while (result > 0 && len < wanted);
+ /* Loop while not (EOF || error) and short reads */
+
+ /* If not enough data read, truncate copy */
+ if (wanted > len)
+ wanted = len;
+ }
+
+ if (wanted > 0) {
+ memcpy (buf, start + data->next_out, wanted);
+ data->next_out += wanted;
+ wanted /= size;
+ }
+ return (int) wanted;
+}
+
static I32
byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
{
dTHR;
OP *saveroot = PL_main_root;
OP *savestart = PL_main_start;
+ struct byteloader_state bstate;
+ struct byteloader_fdata data;
+
+ data.next_out = 0;
+ data.datasv = FILTER_DATA(idx);
+ data.idx = idx;
+
+ bstate.bs_fdata = &data;
+ bstate.bs_obj_list = Null(void**);
+ bstate.bs_obj_list_fill = -1;
+ bstate.bs_sv = Nullsv;
+ bstate.bs_iv_overflows = 0;
- byterun(aTHXo);
+ byterun(aTHXo_ &bstate);
if (PL_in_eval) {
OP *o;
void
import(...)
+ PREINIT:
+ SV *sv = newSVpvn ("", 0);
PPCODE:
- filter_add(byteloader_filter, NULL);
+ if (!sv)
+ croak ("Could not allocate ByteLoader buffers");
+ filter_add(byteloader_filter, sv);
void
unimport(...)
typedef int comment_t;
typedef SV *svindex;
typedef OP *opindex;
+typedef char *pvindex;
typedef IV IV64;
#define BGET_FREAD(argp, len, nelem) \
- PerlIO_read(PL_rsfp,(char*)(argp),(len)*(nelem))
-#define BGET_FGETC() PerlIO_getc(PL_rsfp)
+ bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem))
+#define BGET_FGETC() bl_getc(bstate->bs_fdata)
#define BGET_U32(arg) \
BGET_FREAD(&arg, sizeof(U32), 1)
#define BGET_PV(arg) STMT_START { \
BGET_U32(arg); \
if (arg) { \
- New(666, bytecode_pv.xpv_pv, arg, char); \
- PerlIO_read(PL_rsfp, (void*)bytecode_pv.xpv_pv, arg); \
- bytecode_pv.xpv_len = arg; \
- bytecode_pv.xpv_cur = arg - 1; \
+ New(666, bstate->bs_pv.xpv_pv, arg, char); \
+ bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \
+ bstate->bs_pv.xpv_len = arg; \
+ bstate->bs_pv.xpv_cur = arg - 1; \
} else { \
- bytecode_pv.xpv_pv = 0; \
- bytecode_pv.xpv_len = 0; \
- bytecode_pv.xpv_cur = 0; \
+ bstate->bs_pv.xpv_pv = 0; \
+ bstate->bs_pv.xpv_len = 0; \
+ bstate->bs_pv.xpv_cur = 0; \
} \
} STMT_END
arg = (I32)lo; \
} \
else { \
- bytecode_iv_overflows++; \
+ bstate->bs_iv_overflows++; \
arg = 0; \
} \
} STMT_END
arg = (char *) ary; \
} while (0)
-#define BGET_pvcontents(arg) arg = bytecode_pv.xpv_pv
+#define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv
#define BGET_strconst(arg) STMT_START { \
for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \
arg = PL_tokenbuf; \
} STMT_END
#define BGET_objindex(arg, type) STMT_START { \
- U32 ix; \
BGET_U32(ix); \
- arg = (type)bytecode_obj_list[ix]; \
+ arg = (type)bstate->bs_obj_list[ix]; \
} STMT_END
#define BGET_svindex(arg) BGET_objindex(arg, svindex)
#define BGET_opindex(arg) BGET_objindex(arg, opindex)
+#define BGET_pvindex(arg) STMT_START { \
+ BGET_objindex(arg, pvindex); \
+ arg = arg ? savepv(arg) : arg; \
+ } STMT_END
#define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg]
+#define BSET_stpv(pv, arg) STMT_START { \
+ BSET_OBJ_STORE(pv, arg); \
+ SAVEFREEPV(pv); \
+ } STMT_END
#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg
#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg
#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE)
#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
-#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bytecode_pv.xpv_cur
+#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur
#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
#define BSET_xpv(sv) do { \
- SvPV_set(sv, bytecode_pv.xpv_pv); \
- SvCUR_set(sv, bytecode_pv.xpv_cur); \
- SvLEN_set(sv, bytecode_pv.xpv_len); \
+ SvPV_set(sv, bstate->bs_pv.xpv_pv); \
+ SvCUR_set(sv, bstate->bs_pv.xpv_cur); \
+ SvLEN_set(sv, bstate->bs_pv.xpv_len); \
} while (0)
#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
#define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
#define BSET_hv_store(sv, arg) \
- hv_store((HV*)sv, bytecode_pv.xpv_pv, bytecode_pv.xpv_cur, arg, 0)
+ hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0)
#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
#define BSET_pregcomp(o, arg) \
((PMOP*)o)->op_pmregexp = arg ? \
- CALLREGCOMP(aTHX_ arg, arg + bytecode_pv.xpv_cur, ((PMOP*)o)) : 0
+ CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0
#define BSET_newsv(sv, arg) \
STMT_START { \
sv = (arg == SVt_PVAV ? (SV*)newAV() : \
} STMT_END
#define BSET_ret(foo) STMT_START { \
- if (bytecode_obj_list) \
- Safefree(bytecode_obj_list); \
- LEAVE; \
+ Safefree(bstate->bs_obj_list); \
return; \
} STMT_END
av_store(PL_endav, 0, cv); \
} STMT_END
#define BSET_OBJ_STORE(obj, ix) \
- (I32)ix > bytecode_obj_list_fill ? \
- bset_obj_store(aTHXo_ obj, (I32)ix) : (bytecode_obj_list[ix] = obj)
-#define BYTECODE_HEADER_CHECK \
- STMT_START { \
- U32 sz; \
- strconst str; \
- char *badpart; \
- \
- BGET_U32(sz); /* Magic: 'PLBC' */ \
- if (sz != 0x43424c50) { \
- badpart = "bad magic"; \
- goto bch_fail; \
- } \
- BGET_strconst(str); /* archname */ \
- if (strNE(str, ARCHNAME)) { \
- badpart = "wrong architecture"; \
- goto bch_fail; \
- } \
- BGET_U32(sz); /* ivsize */ \
- if (sz != IVSIZE) { \
- badpart = "different IVSIZE"; \
- goto bch_fail; \
- } \
- BGET_U32(sz); /* ptrsize */ \
- if (sz != PTRSIZE) { \
- badpart = "different PTRSIZE"; \
- goto bch_fail; \
- } \
- BGET_strconst(str); /* byteorder */ \
- if (strNE(str, STRINGIFY(BYTEORDER))) { \
- badpart = "different byteorder"; \
- bch_fail: \
- Perl_croak(aTHX_ "Invalid bytecode for this architecture: %s\n", \
- badpart); \
- } \
+ (I32)ix > bstate->bs_obj_list_fill ? \
+ bset_obj_store(aTHXo_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj)
+
+/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about
+ * what version of Perl it's being called under, it should do a 'require 5.6.0' or
+ * equivalent. However, since the header includes checks requiring an exact match in
+ * ByteLoader versions (we can't guarantee forward compatibility), you don't
+ * need to specify one:
+ * use ByteLoader;
+ * is all you need.
+ * -- BKS, June 2000
+*/
+
+#define HEADER_FAIL(f, arg1, arg2) \
+ Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2)
+
+#define BYTECODE_HEADER_CHECK \
+ STMT_START { \
+ U32 sz = 0; \
+ strconst str; \
+ \
+ BGET_U32(sz); /* Magic: 'PLBC' */ \
+ if (sz != 0x43424c50) { \
+ HEADER_FAIL("bad magic (want 0x43424c50, got %#x)", sz, 0); \
+ } \
+ BGET_strconst(str); /* archname */ \
+ if (strNE(str, ARCHNAME)) { \
+ HEADER_FAIL("wrong architecture (want %s, you have %s)",str,ARCHNAME); \
+ } \
+ BGET_strconst(str); /* ByteLoader version */ \
+ if (strNE(str, VERSION)) { \
+ HEADER_FAIL("mismatched ByteLoader versions (want %s, you have %s)", \
+ str, VERSION); \
+ } \
+ BGET_U32(sz); /* ivsize */ \
+ if (sz != IVSIZE) { \
+ HEADER_FAIL("different IVSIZE", 0, 0); \
+ } \
+ BGET_U32(sz); /* ptrsize */ \
+ if (sz != PTRSIZE) { \
+ HEADER_FAIL("different PTRSIZE", 0, 0); \
+ } \
+ BGET_strconst(str); /* byteorder */ \
+ if (strNE(str, STRINGIFY(BYTEORDER))) { \
+ HEADER_FAIL("different byteorder", 0, 0); \
+ } \
+ Safefree(str); \
} STMT_END
projects / platform / upstream / perl.git / commitdiff