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.07;
  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 sub B::Asmdata::PUT_long {
 150     $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
 151 }
 152
 153 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
 154              b => "\b", f => "\f", v => "\013");
 155
 156 sub uncstring {
 157     my $s = shift;
 158     $s =~ s/^"// and $s =~ s/"$// or return undef;
 159     $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
 160     return $s;
 161 }
 162
 163 sub strip_comments {
 164     my $stmt = shift;
 165     # Comments only allowed in instructions which don't take string arguments
 166     # Treat string as a single line so .* eats \n characters.
 167     $stmt =~ s{
 168         ^\s*    # Ignore leading whitespace
 169         (
 170           [^"]* # A double quote '"' indicates a string argument. If we
 171                 # find a double quote, the match fails and we strip nothing.
 172         )
 173         \s*\#   # Any amount of whitespace plus the comment marker...
 174         .*$     # ...which carries on to end-of-string.
 175     }{$1}sx;    # Keep only the instruction and optional argument.
 176     return $stmt;
 177 }
 178
 179 # create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
 180 #       ptrsize, byteorder
 181 # nvtype is irrelevant (floats are stored as strings)
 182 # byteorder is strconst not U32 because of varying size issues
 183
 184 sub gen_header {
 185     my $header = "";
 186
 187     $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
 188     $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
 189     $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
 190     $header .= B::Asmdata::PUT_U32($Config{ivsize});
 191     $header .= B::Asmdata::PUT_U32($Config{ptrsize});
 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 ### temporary workaround
 290
 291 sub asm {
 292     return if $_[0] =~ /\s*\W/;
 293     if (defined $_[1]) {
 294         return if $_[1] eq "0" and
 295             $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
 296         return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
 297     }
 298     assemble "@_";
 299 }
 300
 301 1;
 302
 303 __END__
 304
 305 =head1 NAME
 306
 307 B::Assembler - Assemble Perl bytecode
 308
 309 =head1 SYNOPSIS
 310
 311         use B::Assembler qw(newasm endasm assemble);
 312         newasm(\&printsub);     # sets up for assembly
 313         assemble($buf);         # assembles one line
 314         endasm();               # closes down
 315
 316         use B::Assembler qw(assemble_fh);
 317         assemble_fh($fh, \&printsub);   # assemble everything in $fh
 318
 319 =head1 DESCRIPTION
 320
 321 See F<ext/B/B/Assembler.pm>.
 322
 323 =head1 AUTHORS
 324
 325 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 326 Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
 327
 328 =cut