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.06;
  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 sub B::Asmdata::PUT_PADOFFSET {
 146     $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
 147 }
 148
 149 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
 150              b => "\b", f => "\f", v => "\013");
 151
 152 sub uncstring {
 153     my $s = shift;
 154     $s =~ s/^"// and $s =~ s/"$// or return undef;
 155     $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
 156     return $s;
 157 }
 158
 159 sub strip_comments {
 160     my $stmt = shift;
 161     # Comments only allowed in instructions which don't take string arguments
 162     # Treat string as a single line so .* eats \n characters.
 163     $stmt =~ s{
 164         ^\s*    # Ignore leading whitespace
 165         (
 166           [^"]* # A double quote '"' indicates a string argument. If we
 167                 # find a double quote, the match fails and we strip nothing.
 168         )
 169         \s*\#   # Any amount of whitespace plus the comment marker...
 170         .*$     # ...which carries on to end-of-string.
 171     }{$1}sx;    # Keep only the instruction and optional argument.
 172     return $stmt;
 173 }
 174
 175 # create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
 176 #       ptrsize, byteorder
 177 # nvtype is irrelevant (floats are stored as strings)
 178 # byteorder is strconst not U32 because of varying size issues
 179
 180 sub gen_header {
 181     my $header = "";
 182
 183     $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
 184     $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
 185     $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
 186     $header .= B::Asmdata::PUT_U32($Config{ivsize});
 187     $header .= B::Asmdata::PUT_U32($Config{ptrsize});
 188     $header;
 189 }
 190
 191 sub parse_statement {
 192     my $stmt = shift;
 193     my ($insn, $arg) = $stmt =~ m{
 194         ^\s*    # allow (but ignore) leading whitespace
 195         (.*?)   # Instruction continues up until...
 196         (?:     # ...an optional whitespace+argument group
 197             \s+         # first whitespace.
 198             (.*)        # The argument is all the rest (newlines included).
 199         )?$     # anchor at end-of-line
 200     }sx;
 201     if (defined($arg)) {
 202         if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
 203             $arg = hex($arg);
 204         } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
 205             $arg = oct($arg);
 206         } elsif ($arg =~ /^pp_/) {
 207             $arg =~ s/\s*$//; # strip trailing whitespace
 208             my $opnum = $opnumber{$arg};
 209             if (defined($opnum)) {
 210                 $arg = $opnum;
 211             } else {
 212                 error qq(No such op type "$arg");
 213                 $arg = 0;
 214             }
 215         }
 216     }
 217     return ($insn, $arg);
 218 }
 219
 220 sub assemble_insn {
 221     my ($insn, $arg) = @_;
 222     my $data = $insn_data{$insn};
 223     if (defined($data)) {
 224         my ($bytecode, $putsub) = @{$data}[0, 1];
 225         my $argcode = &$putsub($arg);
 226         return chr($bytecode).$argcode;
 227     } else {
 228         error qq(no such instruction "$insn");
 229         return "";
 230     }
 231 }
 232
 233 sub assemble_fh {
 234     my ($fh, $out) = @_;
 235     my $line;
 236     my $asm = newasm($out);
 237     while ($line = <$fh>) {
 238         assemble($line);
 239     }
 240     endasm();
 241 }
 242
 243 sub newasm {
 244     my($outsub) = @_;
 245
 246     die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
 247     die <<EOD if ref $out;
 248 Can't have multiple byteassembly sessions at once!
 249         (perhaps you forgot an endasm()?)
 250 EOD
 251
 252     $linenum = $errors = 0;
 253     $out = $outsub;
 254
 255     $out->(gen_header());
 256 }
 257
 258 sub endasm {
 259     if ($errors) {
 260         die "There were $errors assembly errors\n";
 261     }
 262     $linenum = $errors = $out = 0;
 263 }
 264
 265 sub assemble {
 266     my($line) = @_;
 267     my ($insn, $arg);
 268     $linenum++;
 269     chomp $line;
 270     if ($debug) {
 271         my $quotedline = $line;
 272         $quotedline =~ s/\\/\\\\/g;
 273         $quotedline =~ s/"/\\"/g;
 274         $out->(assemble_insn("comment", qq("$quotedline")));
 275     }
 276     if( $line = strip_comments($line) ){
 277         ($insn, $arg) = parse_statement($line);
 278         $out->(assemble_insn($insn, $arg));
 279         if ($debug) {
 280             $out->(assemble_insn("nop", undef));
 281         }
 282     }
 283 }
 284
 285 ### temporary workaround
 286
 287 sub asm {
 288     return if $_[0] =~ /\s*\W/;
 289     if (defined $_[1]) {
 290         return if $_[1] eq "0" and $_[0] !~ /^(?:newsvx?|av_pushx?|xav_flags)$/;
 291         return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
 292     }
 293     assemble "@_";
 294 }
 295
 296 1;
 297
 298 __END__
 299
 300 =head1 NAME
 301
 302 B::Assembler - Assemble Perl bytecode
 303
 304 =head1 SYNOPSIS
 305
 306         use B::Assembler qw(newasm endasm assemble);
 307         newasm(\&printsub);     # sets up for assembly
 308         assemble($buf);         # assembles one line
 309         endasm();               # closes down
 310
 311         use B::Assembler qw(assemble_fh);
 312         assemble_fh($fh, \&printsub);   # assemble everything in $fh
 313
 314 =head1 DESCRIPTION
 315
 316 See F<ext/B/B/Assembler.pm>.
 317
 318 =head1 AUTHORS
 319
 320 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 321 Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
 322
 323 =cut