1N/A# Assembler.pm
1N/A#
1N/A# Copyright (c) 1996 Malcolm Beattie
1N/A#
1N/A# You may distribute under the terms of either the GNU General Public
1N/A# License or the Artistic License, as specified in the README file.
1N/A
1N/Apackage B::Assembler;
1N/Ause Exporter;
1N/Ause B qw(ppname);
1N/Ause B::Asmdata qw(%insn_data @insn_name);
1N/Ause Config qw(%Config);
1N/Arequire ByteLoader; # we just need its $VERSIOM
1N/A
1N/Ano warnings; # XXX
1N/A
1N/A@ISA = qw(Exporter);
1N/A@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
1N/A$VERSION = 0.07;
1N/A
1N/Ause strict;
1N/Amy %opnumber;
1N/Amy ($i, $opname);
1N/Afor ($i = 0; defined($opname = ppname($i)); $i++) {
1N/A $opnumber{$opname} = $i;
1N/A}
1N/A
1N/Amy($linenum, $errors, $out); # global state, set up by newasm
1N/A
1N/Asub error {
1N/A my $str = shift;
1N/A warn "$linenum: $str\n";
1N/A $errors++;
1N/A}
1N/A
1N/Amy $debug = 0;
1N/Asub debug { $debug = shift }
1N/A
1N/Asub limcheck($$$$){
1N/A my( $val, $lo, $hi, $loc ) = @_;
1N/A if( $val < $lo || $hi < $val ){
1N/A error "argument for $loc outside [$lo, $hi]: $val";
1N/A $val = $hi;
1N/A }
1N/A return $val;
1N/A}
1N/A
1N/A#
1N/A# First define all the data conversion subs to which Asmdata will refer
1N/A#
1N/A
1N/Asub B::Asmdata::PUT_U8 {
1N/A my $arg = shift;
1N/A my $c = uncstring($arg);
1N/A if (defined($c)) {
1N/A if (length($c) != 1) {
1N/A error "argument for U8 is too long: $c";
1N/A $c = substr($c, 0, 1);
1N/A }
1N/A } else {
1N/A $arg = limcheck( $arg, 0, 0xff, 'U8' );
1N/A $c = chr($arg);
1N/A }
1N/A return $c;
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_U16 {
1N/A my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
1N/A pack("S", $arg);
1N/A}
1N/Asub B::Asmdata::PUT_U32 {
1N/A my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
1N/A pack("L", $arg);
1N/A}
1N/Asub B::Asmdata::PUT_I32 {
1N/A my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
1N/A pack("l", $arg);
1N/A}
1N/Asub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
1N/A # may not even be portable between compilers
1N/Asub B::Asmdata::PUT_objindex { # could allow names here
1N/A my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
1N/A pack("L", $arg);
1N/A}
1N/Asub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
1N/Asub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
1N/Asub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
1N/A
1N/Asub B::Asmdata::PUT_strconst {
1N/A my $arg = shift;
1N/A my $str = uncstring($arg);
1N/A if (!defined($str)) {
1N/A error "bad string constant: $arg";
1N/A $str = '';
1N/A }
1N/A if ($str =~ s/\0//g) {
1N/A error "string constant argument contains NUL: $arg";
1N/A $str = '';
1N/A }
1N/A return $str . "\0";
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_pvcontents {
1N/A my $arg = shift;
1N/A error "extraneous argument: $arg" if defined $arg;
1N/A return "";
1N/A}
1N/Asub B::Asmdata::PUT_PV {
1N/A my $arg = shift;
1N/A my $str = uncstring($arg);
1N/A if( ! defined($str) ){
1N/A error "bad string argument: $arg";
1N/A $str = '';
1N/A }
1N/A return pack("L", length($str)) . $str;
1N/A}
1N/Asub B::Asmdata::PUT_comment_t {
1N/A my $arg = shift;
1N/A $arg = uncstring($arg);
1N/A error "bad string argument: $arg" unless defined($arg);
1N/A if ($arg =~ s/\n//g) {
1N/A error "comment argument contains linefeed: $arg";
1N/A }
1N/A return $arg . "\n";
1N/A}
1N/Asub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
1N/Asub B::Asmdata::PUT_none {
1N/A my $arg = shift;
1N/A error "extraneous argument: $arg" if defined $arg;
1N/A return "";
1N/A}
1N/Asub B::Asmdata::PUT_op_tr_array {
1N/A my @ary = split /\s*,\s*/, shift;
1N/A return pack "S*", @ary;
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_IV64 {
1N/A return pack "Q", shift;
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_IV {
1N/A $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_PADOFFSET {
1N/A $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
1N/A}
1N/A
1N/Asub B::Asmdata::PUT_long {
1N/A $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
1N/A}
1N/A
1N/Amy %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
1N/A b => "\b", f => "\f", v => "\013");
1N/A
1N/Asub uncstring {
1N/A my $s = shift;
1N/A $s =~ s/^"// and $s =~ s/"$// or return undef;
1N/A $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
1N/A return $s;
1N/A}
1N/A
1N/Asub strip_comments {
1N/A my $stmt = shift;
1N/A # Comments only allowed in instructions which don't take string arguments
1N/A # Treat string as a single line so .* eats \n characters.
1N/A $stmt =~ s{
1N/A ^\s* # Ignore leading whitespace
1N/A (
1N/A [^"]* # A double quote '"' indicates a string argument. If we
1N/A # find a double quote, the match fails and we strip nothing.
1N/A )
1N/A \s*\# # Any amount of whitespace plus the comment marker...
1N/A .*$ # ...which carries on to end-of-string.
1N/A }{$1}sx; # Keep only the instruction and optional argument.
1N/A return $stmt;
1N/A}
1N/A
1N/A# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
1N/A# ptrsize, byteorder
1N/A# nvtype is irrelevant (floats are stored as strings)
1N/A# byteorder is strconst not U32 because of varying size issues
1N/A
1N/Asub gen_header {
1N/A my $header = "";
1N/A
1N/A $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
1N/A $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
1N/A $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
1N/A $header .= B::Asmdata::PUT_U32($Config{ivsize});
1N/A $header .= B::Asmdata::PUT_U32($Config{ptrsize});
1N/A $header;
1N/A}
1N/A
1N/Asub parse_statement {
1N/A my $stmt = shift;
1N/A my ($insn, $arg) = $stmt =~ m{
1N/A ^\s* # allow (but ignore) leading whitespace
1N/A (.*?) # Instruction continues up until...
1N/A (?: # ...an optional whitespace+argument group
1N/A \s+ # first whitespace.
1N/A (.*) # The argument is all the rest (newlines included).
1N/A )?$ # anchor at end-of-line
1N/A }sx;
1N/A if (defined($arg)) {
1N/A if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
1N/A $arg = hex($arg);
1N/A } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
1N/A $arg = oct($arg);
1N/A } elsif ($arg =~ /^pp_/) {
1N/A $arg =~ s/\s*$//; # strip trailing whitespace
1N/A my $opnum = $opnumber{$arg};
1N/A if (defined($opnum)) {
1N/A $arg = $opnum;
1N/A } else {
1N/A error qq(No such op type "$arg");
1N/A $arg = 0;
1N/A }
1N/A }
1N/A }
1N/A return ($insn, $arg);
1N/A}
1N/A
1N/Asub assemble_insn {
1N/A my ($insn, $arg) = @_;
1N/A my $data = $insn_data{$insn};
1N/A if (defined($data)) {
1N/A my ($bytecode, $putsub) = @{$data}[0, 1];
1N/A my $argcode = &$putsub($arg);
1N/A return chr($bytecode).$argcode;
1N/A } else {
1N/A error qq(no such instruction "$insn");
1N/A return "";
1N/A }
1N/A}
1N/A
1N/Asub assemble_fh {
1N/A my ($fh, $out) = @_;
1N/A my $line;
1N/A my $asm = newasm($out);
1N/A while ($line = <$fh>) {
1N/A assemble($line);
1N/A }
1N/A endasm();
1N/A}
1N/A
1N/Asub newasm {
1N/A my($outsub) = @_;
1N/A
1N/A die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
1N/A die <<EOD if ref $out;
1N/ACan't have multiple byteassembly sessions at once!
1N/A (perhaps you forgot an endasm()?)
1N/AEOD
1N/A
1N/A $linenum = $errors = 0;
1N/A $out = $outsub;
1N/A
1N/A $out->(gen_header());
1N/A}
1N/A
1N/Asub endasm {
1N/A if ($errors) {
1N/A die "There were $errors assembly errors\n";
1N/A }
1N/A $linenum = $errors = $out = 0;
1N/A}
1N/A
1N/Asub assemble {
1N/A my($line) = @_;
1N/A my ($insn, $arg);
1N/A $linenum++;
1N/A chomp $line;
1N/A if ($debug) {
1N/A my $quotedline = $line;
1N/A $quotedline =~ s/\\/\\\\/g;
1N/A $quotedline =~ s/"/\\"/g;
1N/A $out->(assemble_insn("comment", qq("$quotedline")));
1N/A }
1N/A if( $line = strip_comments($line) ){
1N/A ($insn, $arg) = parse_statement($line);
1N/A $out->(assemble_insn($insn, $arg));
1N/A if ($debug) {
1N/A $out->(assemble_insn("nop", undef));
1N/A }
1N/A }
1N/A}
1N/A
1N/A### temporary workaround
1N/A
1N/Asub asm {
1N/A return if $_[0] =~ /\s*\W/;
1N/A if (defined $_[1]) {
1N/A return if $_[1] eq "0" and
1N/A $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
1N/A return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
1N/A }
1N/A assemble "@_";
1N/A}
1N/A
1N/A1;
1N/A
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/AB::Assembler - Assemble Perl bytecode
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A use B::Assembler qw(newasm endasm assemble);
1N/A newasm(\&printsub); # sets up for assembly
1N/A assemble($buf); # assembles one line
1N/A endasm(); # closes down
1N/A
1N/A use B::Assembler qw(assemble_fh);
1N/A assemble_fh($fh, \&printsub); # assemble everything in $fh
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/ASee F<ext/B/B/Assembler.pm>.
1N/A
1N/A=head1 AUTHORS
1N/A
1N/AMalcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1N/APer-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
1N/A
1N/A=cut