ext/B/B/Assembler.pm

   1 #      Assembler.pm
   2 #
   3 #      Copyright (c) 1996 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7 package B::Assembler;
   8 use Exporter;
   9 use B qw(ppname);
  10 use B::Asmdata qw(%insn_data @insn_name);
  11
  12 @ISA = qw(Exporter);
  13 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
  14                 parse_statement uncstring);
  15
  16 use strict;
  17 my %opnumber;
  18 my ($i, $opname);
  19 for ($i = 0; defined($opname = ppname($i)); $i++) {
  20     $opnumber{$opname} = $i;
  21 }
  22
  23 my ($linenum, $errors);
  24
  25 sub error {
  26     my $str = shift;
  27     warn "$linenum: $str\n";
  28     $errors++;
  29 }
  30
  31 my $debug = 0;
  32 sub debug { $debug = shift }
  33
  34 #
  35 # First define all the data conversion subs to which Asmdata will refer
  36 #
  37
  38 sub B::Asmdata::PUT_U8 {
  39     my $arg = shift;
  40     my $c = uncstring($arg);
  41     if (defined($c)) {
  42         if (length($c) != 1) {
  43             error "argument for U8 is too long: $c";
  44             $c = substr($c, 0, 1);
  45         }
  46     } else {
  47         $c = chr($arg);
  48     }
  49     return $c;
  50 }
  51
  52 sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
  53 sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
  54 sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
  55 sub B::Asmdata::PUT_NV  { pack("N", $_[0]) }
  56 sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
  57 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
  58 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
  59
  60 sub B::Asmdata::PUT_strconst {
  61     my $arg = shift;
  62     $arg = uncstring($arg);
  63     if (!defined($arg)) {
  64         error "bad string constant: $arg";
  65         return "";
  66     }
  67     if ($arg =~ s/\0//g) {
  68         error "string constant argument contains NUL: $arg";
  69     }
  70     return $arg . "\0";
  71 }
  72
  73 sub B::Asmdata::PUT_pvcontents {
  74     my $arg = shift;
  75     error "extraneous argument: $arg" if defined $arg;
  76     return "";
  77 }
  78 sub B::Asmdata::PUT_PV {
  79     my $arg = shift;
  80     $arg = uncstring($arg);
  81     error "bad string argument: $arg" unless defined($arg);
  82     return pack("N", length($arg)) . $arg;
  83 }
  84 sub B::Asmdata::PUT_comment_t {
  85     my $arg = shift;
  86     $arg = uncstring($arg);
  87     error "bad string argument: $arg" unless defined($arg);
  88     if ($arg =~ s/\n//g) {
  89         error "comment argument contains linefeed: $arg";
  90     }
  91     return $arg . "\n";
  92 }
  93 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
  94 sub B::Asmdata::PUT_none {
  95     my $arg = shift;
  96     error "extraneous argument: $arg" if defined $arg;
  97     return "";
  98 }
  99 sub B::Asmdata::PUT_op_tr_array {
 100     my $arg = shift;
 101     my @ary = split(/\s*,\s*/, $arg);
 102     if (@ary != 256) {
 103         error "wrong number of arguments to op_tr_array";
 104         @ary = (0) x 256;
 105     }
 106     return pack("n256", @ary);
 107 }
 108 # XXX Check this works
 109 sub B::Asmdata::PUT_IV64 {
 110     my $arg = shift;
 111     return pack("NN", $arg >> 32, $arg & 0xffffffff);
 112 }
 113
 114 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
 115              b => "\b", f => "\f", v => "\013");
 116
 117 sub uncstring {
 118     my $s = shift;
 119     $s =~ s/^"// and $s =~ s/"$// or return undef;
 120     $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
 121     return $s;
 122 }
 123
 124 sub strip_comments {
 125     my $stmt = shift;
 126     # Comments only allowed in instructions which don't take string arguments
 127     $stmt =~ s{
 128         (?sx)   # Snazzy extended regexp coming up. Also, treat
 129                 # string as a single line so .* eats \n characters.
 130         ^\s*    # Ignore leading whitespace
 131         (
 132           [^"]* # A double quote '"' indicates a string argument. If we
 133                 # find a double quote, the match fails and we strip nothing.
 134         )
 135         \s*\#   # Any amount of whitespace plus the comment marker...
 136         .*$     # ...which carries on to end-of-string.
 137     }{$1};      # Keep only the instruction and optional argument.
 138     return $stmt;
 139 }
 140
 141 sub parse_statement {
 142     my $stmt = shift;
 143     my ($insn, $arg) = $stmt =~ m{
 144         (?sx)
 145         ^\s*    # allow (but ignore) leading whitespace
 146         (.*?)   # Instruction continues up until...
 147         (?:     # ...an optional whitespace+argument group
 148             \s+         # first whitespace.
 149             (.*)        # The argument is all the rest (newlines included).
 150         )?$     # anchor at end-of-line
 151     };
 152     if (defined($arg)) {
 153         if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
 154             $arg = hex($arg);
 155         } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
 156             $arg = oct($arg);
 157         } elsif ($arg =~ /^pp_/) {
 158             $arg =~ s/\s*$//; # strip trailing whitespace
 159             my $opnum = $opnumber{$arg};
 160             if (defined($opnum)) {
 161                 $arg = $opnum;
 162             } else {
 163                 error qq(No such op type "$arg");
 164                 $arg = 0;
 165             }
 166         }
 167     }
 168     return ($insn, $arg);
 169 }
 170
 171 sub assemble_insn {
 172     my ($insn, $arg) = @_;
 173     my $data = $insn_data{$insn};
 174     if (defined($data)) {
 175         my ($bytecode, $putsub) = @{$data}[0, 1];
 176         my $argcode = &$putsub($arg);
 177         return chr($bytecode).$argcode;
 178     } else {
 179         error qq(no such instruction "$insn");
 180         return "";
 181     }
 182 }
 183
 184 sub assemble_fh {
 185     my ($fh, $out) = @_;
 186     my ($line, $insn, $arg);
 187     $linenum = 0;
 188     $errors = 0;
 189     while ($line = <$fh>) {
 190         $linenum++;
 191         chomp $line;
 192         if ($debug) {
 193             my $quotedline = $line;
 194             $quotedline =~ s/\\/\\\\/g;
 195             $quotedline =~ s/"/\\"/g;
 196             &$out(assemble_insn("comment", qq("$quotedline")));
 197         }
 198         $line = strip_comments($line) or next;
 199         ($insn, $arg) = parse_statement($line);
 200         &$out(assemble_insn($insn, $arg));
 201         if ($debug) {
 202             &$out(assemble_insn("nop", undef));
 203         }
 204     }
 205     if ($errors) {
 206         die "Assembly failed with $errors error(s)\n";
 207     }
 208 }
 209
 210 1;
 211
 212 __END__
 213
 214 =head1 NAME
 215
 216 B::Assembler - Assemble Perl bytecode
 217
 218 =head1 SYNOPSIS
 219
 220         use Assembler;
 221
 222 =head1 DESCRIPTION
 223
 224 See F<ext/B/B/Assembler.pm>.
 225
 226 =head1 AUTHOR
 227
 228 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 229
 230 =cut