ext/B/t/assembler.t

   1 #!./perl -w
   2
   3 =pod
   4
   5 =head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
   6
   7 =head2 Description
   8
   9 The general idea is to test by assembling a choice set of assembler
  10 instructions, then disassemble them, and check that we've completed the
  11 round trip. Also, error checking of Assembler.pm is tested by feeding
  12 it assorted errors.
  13
  14 Since Assembler.pm likes to assemble a file, we comply by writing a
  15 text file. This file contains three sections:
  16
  17   testing operand categories
  18   use each opcode
  19   erronous assembler instructions
  20
  21 An "operand category" is identified by the suffix of the PUT_/GET_
  22 subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
  23 opcode C<ldsv> has operand category C<svindex>:
  24
  25    insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
  26
  27 Because Disassembler.pm also assumes input from a file, we write the
  28 resulting object code to a file. And disassembled output is written to
  29 yet another text file which is then compared to the original input.
  30 (Erronous assembler instructions still generate code, but this is not
  31 written to the object file; therefore disassembly bails out at the first
  32 instruction in error.)
  33
  34 All files are kept in memory by using TIEHASH.
  35
  36
  37 =head2 Caveats
  38
  39 An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
  40 generates invalid object code will not be detected.
  41
  42 Due to the way this test has been set up, failure of a single test
  43 could cause all subsequent tests to fail as well: After an unexpected
  44 assembler error no output is written, and disassembled lines will be
  45 out of sync for all lines thereafter.
  46
  47 Not all possibilities for writing a valid operand value can be tested
  48 because disassembly results in a uniform representation.
  49
  50
  51 =head2 Maintenance
  52
  53 New opcodes are added automatically.
  54
  55 A new operand category will cause this program to die ("no operand list
  56 for XXX"). The cure is to add suitable entries to C<%goodlist> and
  57 C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
  58 happen that the corresponding assembly or disassembly subroutine is
  59 missing.) Note that an empty array as a C<%goodlist> entry means that
  60 opcodes of the operand category do not take an operand (and therefore the
  61 corresponding entry in C<%badlist> should have one). An C<undef> entry
  62 in C<%badlist> means that any value is acceptable (and thus there is no
  63 way to cause an error).
  64
  65 Set C<$dbg> to debug this test.
  66
  67 =cut
  68
  69 package VirtFile;
  70 use strict;
  71
  72 # Note: This is NOT a general purpose package. It implements
  73 # sequential text and binary file i/o in a rather simple form.
  74
  75 sub TIEHANDLE($;$){
  76     my( $class, $data ) = @_;
  77     my $obj = { data => defined( $data ) ? $data : '',
  78                 pos => 0 };
  79     return bless( $obj, $class );
  80 }
  81
  82 sub PRINT($@){
  83     my( $self ) = shift;
  84     $self->{data} .= join( '', @_ );
  85 }
  86
  87 sub WRITE($$;$$){
  88     my( $self, $buf, $len, $offset ) = @_;
  89     unless( defined( $len ) ){
  90         $len = length( $buf );
  91         $offset = 0;
  92     }
  93     unless( defined( $offset ) ){
  94         $offset = 0;
  95     }
  96     $self->{data} .= substr( $buf, $offset, $len );
  97     return $len;
  98 }
  99
 100
 101 sub GETC($){
 102     my( $self ) = @_;
 103     return undef() if $self->{pos} >= length( $self->{data} );
 104     return substr( $self->{data}, $self->{pos}++, 1 );
 105 }
 106
 107 sub READLINE($){
 108     my( $self ) = @_;
 109     return undef() if $self->{pos} >= length( $self->{data} );
 110     my $lfpos = index( $self->{data}, "\n", $self->{pos} );
 111     if( $lfpos < 0 ){
 112         $lfpos = length( $self->{data} );
 113     }
 114     my $pos = $self->{pos};
 115     $self->{pos} = $lfpos + 1;
 116     return substr( $self->{data}, $pos, $self->{pos} - $pos );
 117 }
 118
 119 sub READ($@){
 120     my $self = shift();
 121     my $bufref = \$_[0];
 122     my( undef, $len, $offset ) = @_;
 123     if( $offset ){
 124         die( "offset beyond end of buffer\n" )
 125           if ! defined( $$bufref ) || $offset > length( $$bufref );
 126     } else {
 127         $$bufref = '';
 128         $offset = 0;
 129     }
 130     my $remlen = length( $self->{data} ) - $self->{pos};
 131     $len = $remlen if $remlen < $len;
 132     return 0 unless $len;
 133     substr( $$bufref, $offset, $len ) =
 134       substr( $self->{data}, $self->{pos}, $len );
 135     $self->{pos} += $len;
 136     return $len;
 137 }
 138
 139 sub TELL($){
 140     my $self = shift();
 141     return $self->{pos};
 142 }
 143
 144 sub CLOSE($){
 145     my( $self ) = @_;
 146     $self->{pos} = 0;
 147 }
 148
 149 1;
 150
 151 package main;
 152
 153 use strict;
 154 use Test::More;
 155 use Config qw(%Config);
 156
 157 use B::Asmdata      qw( %insn_data );
 158 use B::Assembler    qw( &assemble_fh );
 159 use B::Disassembler qw( &disassemble_fh &get_header );
 160
 161 my( %opsByType, @code2name );
 162 my( $lineno, $dbg, $firstbadline, @descr );
 163 $dbg = 0; # debug switch
 164
 165 # $SIG{__WARN__} handler to catch Assembler error messages
 166 #
 167 my $warnmsg;
 168 sub catchwarn($){
 169     $warnmsg = $_[0];
 170     print "error: $warnmsg\n" if $dbg;
 171 }
 172
 173 # Callback for writing assembled bytes. This is where we check
 174 # that we do get an error.
 175 #
 176 sub putobj($){
 177     if( ++$lineno >= $firstbadline ){
 178         ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
 179         undef( $warnmsg );
 180     } else {
 181         my $l = syswrite( OBJ, $_[0] );
 182     }
 183 }
 184
 185 # Callback for writing a disassembled statement.
 186 #
 187 sub putdis(@){
 188     my $line = join( ' ', @_ );
 189     ++$lineno;
 190     print DIS "$line\n";
 191     printf "%5d %s\n", $lineno, $line if $dbg;
 192 }
 193
 194 # Generate assembler instructions from a hash of operand types: each
 195 # existing entry contains a list of good or bad operand values. The
 196 # corresponding opcodes can be found in %opsByType.
 197 #
 198 sub gen_type($$$){
 199     my( $href, $descref, $text ) = @_;
 200     for my $odt ( sort( keys( %opsByType ) ) ){
 201         my $opcode = $opsByType{$odt}->[0];
 202         my $sel = $odt;
 203         $sel =~ s/^GET_//;
 204         die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
 205         if( defined( $href->{$sel} ) ){
 206             if( @{$href->{$sel}} ){
 207                 for my $od ( @{$href->{$sel}} ){
 208                     ++$lineno;
 209                     $descref->[$lineno] = "$text: $code2name[$opcode] $od";
 210                     print ASM "$code2name[$opcode] $od\n";
 211                     printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
 212                 }
 213             } else {
 214                 ++$lineno;
 215                 $descref->[$lineno] = "$text: $code2name[$opcode]";
 216                 print ASM "$code2name[$opcode]\n";
 217                 printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
 218             }
 219         }
 220     }
 221 }
 222
 223 # Interesting operand values
 224 #
 225 my %goodlist = (
 226 comment_t   => [ '"a comment"' ],  # no \n
 227 none        => [],
 228 svindex     => [ 0x7fffffff, 0 ],
 229 opindex     => [ 0x7fffffff, 0 ],
 230 pvindex     => [ 0x7fffffff, 0 ],
 231 U32         => [ 0xffffffff, 0 ],
 232 U8          => [ 0xff, 0 ],
 233 PV          => [ '""', '"a string"', ],
 234 I32         => [ -0x80000000, 0x7fffffff ],
 235 IV64        => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats  0x%09x
 236 IV          => $Config{ivsize} == 4 ?
 237                [ -0x80000000, 0x7fffffff ] :
 238                [ '0x000000000', '0x0ffffffff', '0x000000001' ],
 239 NV          => [ 1.23456789E3 ],
 240 U16         => [ 0xffff, 0 ],
 241 pvcontents  => [],
 242 strconst    => [ '""', '"another string"' ], # no NUL
 243 op_tr_array => [ join( ',', 0..255 ) ],
 244               );
 245
 246 # Erronous operand values
 247 #
 248 my %badlist = (
 249 comment_t   => [ '"multi-line\ncomment"' ],  # no \n
 250 none        => [ '"spurious arg"'  ],
 251 svindex     => [ 0xffffffff * 2, -1 ],
 252 opindex     => [ 0xffffffff * 2, -2 ],
 253 pvindex     => [ 0xffffffff * 2, -3 ],
 254 U32         => [ 0xffffffff * 2, -4 ],
 255 U16         => [ 0x5ffff, -5 ],
 256 U8          => [ 0x6ff, -6 ],
 257 PV          => [ 'no quote"' ],
 258 I32         => [ -0x80000001, 0x80000000 ],
 259 IV64        => undef, # PUT_IV64 doesn't check - no integrity there
 260 IV          => $Config{ivsize} == 4 ?
 261                [ -0x80000001, 0x80000000 ] : undef,
 262 NV          => undef, # PUT_NV accepts anything - it shouldn't, real-ly
 263 pvcontents  => [ '"spurious arg"' ],
 264 strconst    => [  'no quote"',  '"with NUL '."\0".' char"' ], # no NUL
 265 op_tr_array => [ join( ',', 1..42 ) ],
 266               );
 267
 268
 269 # Determine all operand types from %Asmdata::insn_data
 270 #
 271 for my $opname ( keys( %insn_data ) ){
 272     my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
 273     push( @{$opsByType{$getname}}, $opcode );
 274     $code2name[$opcode] = $opname;
 275 }
 276
 277
 278 # Write instruction(s) for correct operand values each operand type class
 279 #
 280 $lineno = 0;
 281 tie( *ASM, 'VirtFile' );
 282 gen_type( \%goodlist, \@descr, 'round trip' );
 283
 284 # Write one instruction for each opcode.
 285 #
 286 for my $opcode ( 0..$#code2name ){
 287     next unless defined( $code2name[$opcode] );
 288     my $sel = $insn_data{$code2name[$opcode]}->[2];
 289     $sel =~ s/^GET_//;
 290     die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
 291     if( defined( $goodlist{$sel} ) ){
 292         ++$lineno;
 293         if( @{$goodlist{$sel}} ){
 294             my $od = $goodlist{$sel}[0];
 295             $descr[$lineno] = "round trip: $code2name[$opcode] $od";
 296             print ASM "$code2name[$opcode] $od\n";
 297             printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
 298         } else {
 299             $descr[$lineno] = "round trip: $code2name[$opcode]";
 300             print ASM "$code2name[$opcode]\n";
 301             printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
 302         }
 303     }
 304 }
 305
 306 # Write instruction(s) for incorrect operand values each operand type class
 307 #
 308 $firstbadline = $lineno + 1;
 309 gen_type( \%badlist, \@descr, 'asm error' );
 310
 311 # invalid opcode is an odd-man-out ;-)
 312 #
 313 ++$lineno;
 314 $descr[$lineno] = "asm error: Gollum";
 315 print ASM "Gollum\n";
 316 printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
 317
 318 close( ASM );
 319
 320 # Now that we have defined all of our tests: plan
 321 #
 322 plan( tests => $lineno );
 323 print "firstbadline=$firstbadline\n" if $dbg;
 324
 325 # assemble (guard against warnings and death from assembly errors)
 326 #
 327 $SIG{'__WARN__'} = \&catchwarn;
 328
 329 $lineno = -1; # account for the assembly header
 330 tie( *OBJ, 'VirtFile' );
 331 eval { assemble_fh( \*ASM, \&putobj ); };
 332 print "eval: $@" if $dbg;
 333 close( ASM );
 334 close( OBJ );
 335 $SIG{'__WARN__'} = 'DEFAULT';
 336
 337 # disassemble
 338 #
 339 print "--- disassembling ---\n" if $dbg;
 340 $lineno = 0;
 341 tie( *DIS, 'VirtFile' );
 342 disassemble_fh( \*OBJ, \&putdis );
 343 close( OBJ );
 344 close( DIS );
 345
 346 # get header (for debugging only)
 347 #
 348 if( $dbg ){
 349     my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
 350         get_header();
 351     printf "Magic:        0x%08x\n", $magic;
 352     print  "Architecture: $archname\n";
 353     print  "Byteloader V: $blversion\n";
 354     print  "ivsize:       $ivsize\n";
 355     print  "ptrsize:      $ptrsize\n";
 356     print  "Byteorder:    $byteorder\n";
 357 }
 358
 359 # check by comparing files line by line
 360 #
 361 print "--- checking ---\n" if $dbg;
 362 $lineno = 0;
 363 my( $asmline, $disline );
 364 while( defined( $asmline = <ASM> ) ){
 365     $disline = <DIS>;
 366     ++$lineno;
 367     last if $lineno eq $firstbadline; # bail out where errors begin
 368     ok( $asmline eq $disline, $descr[$lineno] );
 369     printf "%5d %s\n", $lineno, $asmline if $dbg;
 370 }
 371 close( ASM );
 372 close( DIS );
 373
 374 __END__