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