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
   8 package B::Assembler;
   9 use Exporter;
  10 use B qw(ppname);
  11 use B::Asmdata qw(%insn_data @insn_name);
  12 use Config qw(%Config);
  13 require ByteLoader;             # we just need its $VERSIOM
  14
  15 @ISA = qw(Exporter);
  16 @EXPORT_OK = qw(assemble_fh newasm endasm assemble);
  17 $VERSION = 0.04;
  18
  19 use strict;
  20 my %opnumber;
  21 my ($i, $opname);
  22 for ($i = 0; defined($opname = ppname($i)); $i++) {
  23     $opnumber{$opname} = $i;
  24 }
  25
  26 my($linenum, $errors, $out); #  global state, set up by newasm
  27
  28 sub error {
  29     my $str = shift;
  30     warn "$linenum: $str\n";
  31     $errors++;
  32 }
  33
  34 my $debug = 0;
  35 sub debug { $debug = shift }
  36
  37 sub limcheck($$$$){
  38     my( $val, $lo, $hi, $loc ) = @_;
  39     if( $val < $lo || $hi < $val ){
  40         error "argument for $loc outside [$lo, $hi]: $val";
  41         $val = $hi;
  42     }
  43     return $val;
  44 }
  45
  46 #
  47 # First define all the data conversion subs to which Asmdata will refer
  48 #
  49
  50 sub B::Asmdata::PUT_U8 {
  51     my $arg = shift;
  52     my $c = uncstring($arg);
  53     if (defined($c)) {
  54         if (length($c) != 1) {
  55             error "argument for U8 is too long: $c";
  56             $c = substr($c, 0, 1);
  57         }
  58     } else {
  59         $arg = limcheck( $arg, 0, 0xff, 'U8' );
  60         $c = chr($arg);
  61     }
  62     return $c;
  63 }
  64
  65 sub B::Asmdata::PUT_U16 {
  66     my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
  67     pack("S", $arg);
  68 }
  69 sub B::Asmdata::PUT_U32 {
  70     my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
  71     pack("L", $arg);
  72 }
  73 sub B::Asmdata::PUT_I32 {
  74     my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
  75     pack("L", $arg);
  76 }
  77 sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
  78                                                    # may not even be portable between compilers
  79 sub B::Asmdata::PUT_objindex { # could allow names here
  80     my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
  81     pack("L", $arg);
  82 }
  83 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
  84 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
  85 sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
  86
  87 sub B::Asmdata::PUT_strconst {
  88     my $arg = shift;
  89     my $str = uncstring($arg);
  90     if (!defined($str)) {
  91         error "bad string constant: $arg";
  92         $str = '';
  93     }
  94     if ($str =~ s/\0//g) {
  95         error "string constant argument contains NUL: $arg";
  96         $str = '';
  97     }
  98     return $str . "\0";
  99 }
 100
 101 sub B::Asmdata::PUT_pvcontents {
 102     my $arg = shift;
 103     error "extraneous argument: $arg" if defined $arg;
 104     return "";
 105 }
 106 sub B::Asmdata::PUT_PV {
 107     my $arg = shift;
 108     my $str = uncstring($arg);
 109     if( ! defined($str) ){
 110         error "bad string argument: $arg";
 111         $str = '';
 112     }
 113     return pack("L", length($str)) . $str;
 114 }
 115 sub B::Asmdata::PUT_comment_t {
 116     my $arg = shift;
 117     $arg = uncstring($arg);
 118     error "bad string argument: $arg" unless defined($arg);
 119     if ($arg =~ s/\n//g) {
 120         error "comment argument contains linefeed: $arg";
 121     }
 122     return $arg . "\n";
 123 }
 124 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
 125 sub B::Asmdata::PUT_none {
 126     my $arg = shift;
 127     error "extraneous argument: $arg" if defined $arg;
 128     return "";
 129 }
 130 sub B::Asmdata::PUT_op_tr_array {
 131     my $arg = shift;
 132     my @ary = split(/\s*,\s*/, $arg);
 133     if (@ary != 256) {
 134         error "wrong number of arguments to op_tr_array";
 135         @ary = (0) x 256;
 136     }
 137     return pack("S256", @ary);
 138 }
 139 # XXX Check this works
 140 # Note: $arg >> 32 is a no-op on 32-bit systems
 141 sub B::Asmdata::PUT_IV64 {
 142     my $arg = shift;
 143     return pack("LL", ($arg >> 16) >>16 , $arg & 0xffffffff);
 144 }
 145
 146 sub B::Asmdata::PUT_IV {
 147     $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
 148 }
 149
 150 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
 151              b => "\b", f => "\f", v => "\013");
 152
 153 sub uncstring {
 154     my $s = shift;
 155     $s =~ s/^"// and $s =~ s/"$// or return undef;
 156     $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
 157     return $s;
 158 }
 159
 160 sub strip_comments {
 161     my $stmt = shift;
 162     # Comments only allowed in instructions which don't take string arguments
 163     $stmt =~ s{
 164         (?sx)   # Snazzy extended regexp coming up. Also, treat
 165                 # string as a single line so .* eats \n characters.
 166         ^\s*    # Ignore leading whitespace
 167         (
 168           [^"]* # A double quote '"' indicates a string argument. If we
 169                 # find a double quote, the match fails and we strip nothing.
 170         )
 171         \s*\#   # Any amount of whitespace plus the comment marker...
 172         .*$     # ...which carries on to end-of-string.
 173     }{$1};      # Keep only the instruction and optional argument.
 174     return $stmt;
 175 }
 176
 177 # create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
 178 #       ptrsize, byteorder
 179 # nvtype is irrelevant (floats are stored as strings)
 180 # byteorder is strconst not U32 because of varying size issues
 181
 182 sub gen_header {
 183     my $header = "";
 184
 185     $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
 186     $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
 187     $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
 188     $header .= B::Asmdata::PUT_U32($Config{ivsize});
 189     $header .= B::Asmdata::PUT_U32($Config{ptrsize});
 190     $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
 191
 192     $header;
 193 }
 194
 195 sub parse_statement {
 196     my $stmt = shift;
 197     my ($insn, $arg) = $stmt =~ m{
 198         ^\s*    # allow (but ignore) leading whitespace
 199         (.*?)   # Instruction continues up until...
 200         (?:     # ...an optional whitespace+argument group
 201             \s+         # first whitespace.
 202             (.*)        # The argument is all the rest (newlines included).
 203         )?$     # anchor at end-of-line
 204     }sx;
 205     if (defined($arg)) {
 206         if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
 207             $arg = hex($arg);
 208         } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
 209             $arg = oct($arg);
 210         } elsif ($arg =~ /^pp_/) {
 211             $arg =~ s/\s*$//; # strip trailing whitespace
 212             my $opnum = $opnumber{$arg};
 213             if (defined($opnum)) {
 214                 $arg = $opnum;
 215             } else {
 216                 error qq(No such op type "$arg");
 217                 $arg = 0;
 218             }
 219         }
 220     }
 221     return ($insn, $arg);
 222 }
 223
 224 sub assemble_insn {
 225     my ($insn, $arg) = @_;
 226     my $data = $insn_data{$insn};
 227     if (defined($data)) {
 228         my ($bytecode, $putsub) = @{$data}[0, 1];
 229         my $argcode = &$putsub($arg);
 230         return chr($bytecode).$argcode;
 231     } else {
 232         error qq(no such instruction "$insn");
 233         return "";
 234     }
 235 }
 236
 237 sub assemble_fh {
 238     my ($fh, $out) = @_;
 239     my $line;
 240     my $asm = newasm($out);
 241     while ($line = <$fh>) {
 242         assemble($line);
 243     }
 244     endasm();
 245 }
 246
 247 sub newasm {
 248     my($outsub) = @_;
 249
 250     die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
 251     die <<EOD if ref $out;
 252 Can't have multiple byteassembly sessions at once!
 253         (perhaps you forgot an endasm()?)
 254 EOD
 255
 256     $linenum = $errors = 0;
 257     $out = $outsub;
 258
 259     $out->(gen_header());
 260 }
 261
 262 sub endasm {
 263     if ($errors) {
 264         die "There were $errors assembly errors\n";
 265     }
 266     $linenum = $errors = $out = 0;
 267 }
 268
 269 sub assemble {
 270     my($line) = @_;
 271     my ($insn, $arg);
 272     $linenum++;
 273     chomp $line;
 274     if ($debug) {
 275         my $quotedline = $line;
 276         $quotedline =~ s/\\/\\\\/g;
 277         $quotedline =~ s/"/\\"/g;
 278         $out->(assemble_insn("comment", qq("$quotedline")));
 279     }
 280     if( $line = strip_comments($line) ){
 281         ($insn, $arg) = parse_statement($line);
 282         $out->(assemble_insn($insn, $arg));
 283         if ($debug) {
 284             $out->(assemble_insn("nop", undef));
 285         }
 286     }
 287 }
 288
 289 1;
 290
 291 __END__
 292
 293 =head1 NAME
 294
 295 B::Assembler - Assemble Perl bytecode
 296
 297 =head1 SYNOPSIS
 298
 299         use B::Assembler qw(newasm endasm assemble);
 300         newasm(\&printsub);     # sets up for assembly
 301         assemble($buf);         # assembles one line
 302         endasm();               # closes down
 303
 304         use B::Assembler qw(assemble_fh);
 305         assemble_fh($fh, \&printsub);   # assemble everything in $fh
 306
 307 =head1 DESCRIPTION
 308
 309 See F<ext/B/B/Assembler.pm>.
 310
 311 =head1 AUTHORS
 312
 313 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 314 Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
 315
 316 =cut