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