home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _65115b6443a0d12d512c275995273d5c < prev    next >
Text File  |  2004-06-01  |  8KB  |  329 lines
  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
  329.