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