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 BEGIN {
 158   if (($Config{'extensions'} !~ /\bB\b/) ){
 159     print "1..0 # Skip -- Perl configured without B module\n";
 160     exit 0;
 161   }
 162   if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
 163     print "1..0 # Skip -- Perl configured without ByteLoader module\n";
 164     exit 0;
 165   }
 166 }
 167
 168 use B::Asmdata      qw( %insn_data );
 169 use B::Assembler    qw( &assemble_fh );
 170 use B::Disassembler qw( &disassemble_fh &get_header );
 171
 172 my( %opsByType, @code2name );
 173 my( $lineno, $dbg, $firstbadline, @descr );
 174 $dbg = 0; # debug switch
 175
 176 # $SIG{__WARN__} handler to catch Assembler error messages
 177 #
 178 my $warnmsg;
 179 sub catchwarn($){
 180     $warnmsg = $_[0];
 181     print "error: $warnmsg\n" if $dbg;
 182 }
 183
 184 # Callback for writing assembled bytes. This is where we check
 185 # that we do get an error.
 186 #
 187 sub putobj($){
 188     if( ++$lineno >= $firstbadline ){
 189         ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
 190         undef( $warnmsg );
 191     } else {
 192         my $l = syswrite( OBJ, $_[0] );
 193     }
 194 }
 195
 196 # Callback for writing a disassembled statement.
 197 #
 198 sub putdis(@){
 199     my $line = join( ' ', @_ );
 200     ++$lineno;
 201     print DIS "$line\n";
 202     printf "%5d %s\n", $lineno, $line if $dbg;
 203 }
 204
 205 # Generate assembler instructions from a hash of operand types: each
 206 # existing entry contains a list of good or bad operand values. The
 207 # corresponding opcodes can be found in %opsByType.
 208 #
 209 sub gen_type($$$){
 210     my( $href, $descref, $text ) = @_;
 211     for my $odt ( sort( keys( %opsByType ) ) ){
 212         my $opcode = $opsByType{$odt}->[0];
 213         my $sel = $odt;
 214         $sel =~ s/^GET_//;
 215         die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
 216         if( defined( $href->{$sel} ) ){
 217             if( @{$href->{$sel}} ){
 218                 for my $od ( @{$href->{$sel}} ){
 219                     ++$lineno;
 220                     $descref->[$lineno] = "$text: $code2name[$opcode] $od";
 221                     print ASM "$code2name[$opcode] $od\n";
 222                     printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
 223                 }
 224             } else {
 225                 ++$lineno;
 226                 $descref->[$lineno] = "$text: $code2name[$opcode]";
 227                 print ASM "$code2name[$opcode]\n";
 228                 printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
 229             }
 230         }
 231     }
 232 }
 233
 234 # Interesting operand values
 235 #
 236 my %goodlist = (
 237 comment_t   => [ '"a comment"' ],  # no \n
 238 none        => [],
 239 svindex     => [ 0x7fffffff, 0 ],
 240 opindex     => [ 0x7fffffff, 0 ],
 241 pvindex     => [ 0x7fffffff, 0 ],
 242 U32         => [ 0xffffffff, 0 ],
 243 U8          => [ 0xff, 0 ],
 244 PV          => [ '""', '"a string"', ],
 245 I32         => [ -0x80000000, 0x7fffffff ],
 246 IV64        => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats  0x%09x
 247 IV          => $Config{ivsize} == 4 ?
 248                [ -0x80000000, 0x7fffffff ] :
 249                [ '0x000000000', '0x0ffffffff', '0x000000001' ],
 250 NV          => [ 1.23456789E3 ],
 251 U16         => [ 0xffff, 0 ],
 252 pvcontents  => [],
 253 strconst    => [ '""', '"another string"' ], # no NUL
 254 op_tr_array => [ join( ',', 256, 0..255 ) ],
 255 PADOFFSET   => undef,
 256 long        => undef,
 257               );
 258
 259 # Erronous operand values
 260 #
 261 my %badlist = (
 262 comment_t   => [ '"multi-line\ncomment"' ],  # no \n
 263 none        => [ '"spurious arg"'  ],
 264 svindex     => [ 0xffffffff * 2, -1 ],
 265 opindex     => [ 0xffffffff * 2, -2 ],
 266 pvindex     => [ 0xffffffff * 2, -3 ],
 267 U32         => [ 0xffffffff * 2, -4 ],
 268 U16         => [ 0x5ffff, -5 ],
 269 U8          => [ 0x6ff, -6 ],
 270 PV          => [ 'no quote"' ],
 271 I32         => [ -0x80000001, 0x80000000 ],
 272 IV64        => undef, # PUT_IV64 doesn't check - no integrity there
 273 IV          => $Config{ivsize} == 4 ?
 274                [ -0x80000001, 0x80000000 ] : undef,
 275 NV          => undef, # PUT_NV accepts anything - it shouldn't, real-ly
 276 pvcontents  => [ '"spurious arg"' ],
 277 strconst    => [  'no quote"',  '"with NUL '."\0".' char"' ], # no NUL
 278 op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
 279 PADOFFSET   => undef,
 280 long         => undef,
 281               );
 282
 283
 284 # Determine all operand types from %Asmdata::insn_data
 285 #
 286 for my $opname ( keys( %insn_data ) ){
 287     my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
 288     push( @{$opsByType{$getname}}, $opcode );
 289     $code2name[$opcode] = $opname;
 290 }
 291
 292
 293 # Write instruction(s) for correct operand values each operand type class
 294 #
 295 $lineno = 0;
 296 tie( *ASM, 'VirtFile' );
 297 gen_type( \%goodlist, \@descr, 'round trip' );
 298
 299 # Write one instruction for each opcode.
 300 #
 301 for my $opcode ( 0..$#code2name ){
 302     next unless defined( $code2name[$opcode] );
 303     my $sel = $insn_data{$code2name[$opcode]}->[2];
 304     $sel =~ s/^GET_//;
 305     die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
 306     if( defined( $goodlist{$sel} ) ){
 307         ++$lineno;
 308         if( @{$goodlist{$sel}} ){
 309             my $od = $goodlist{$sel}[0];
 310             $descr[$lineno] = "round trip: $code2name[$opcode] $od";
 311             print ASM "$code2name[$opcode] $od\n";
 312             printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
 313         } else {
 314             $descr[$lineno] = "round trip: $code2name[$opcode]";
 315             print ASM "$code2name[$opcode]\n";
 316             printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
 317         }
 318     }
 319 }
 320
 321 # Write instruction(s) for incorrect operand values each operand type class
 322 #
 323 $firstbadline = $lineno + 1;
 324 gen_type( \%badlist, \@descr, 'asm error' );
 325
 326 # invalid opcode is an odd-man-out ;-)
 327 #
 328 ++$lineno;
 329 $descr[$lineno] = "asm error: Gollum";
 330 print ASM "Gollum\n";
 331 printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
 332
 333 close( ASM );
 334
 335 # Now that we have defined all of our tests: plan
 336 #
 337 plan( tests => $lineno );
 338 print "firstbadline=$firstbadline\n" if $dbg;
 339
 340 # assemble (guard against warnings and death from assembly errors)
 341 #
 342 $SIG{'__WARN__'} = \&catchwarn;
 343
 344 $lineno = -1; # account for the assembly header
 345 tie( *OBJ, 'VirtFile' );
 346 eval { assemble_fh( \*ASM, \&putobj ); };
 347 print "eval: $@" if $dbg;
 348 close( ASM );
 349 close( OBJ );
 350 $SIG{'__WARN__'} = 'DEFAULT';
 351
 352 # disassemble
 353 #
 354 print "--- disassembling ---\n" if $dbg;
 355 $lineno = 0;
 356 tie( *DIS, 'VirtFile' );
 357 disassemble_fh( \*OBJ, \&putdis );
 358 close( OBJ );
 359 close( DIS );
 360
 361 # get header (for debugging only)
 362 #
 363 if( $dbg ){
 364     my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
 365         get_header();
 366     printf "Magic:        0x%08x\n", $magic;
 367     print  "Architecture: $archname\n";
 368     print  "Byteloader V: $blversion\n";
 369     print  "ivsize:       $ivsize\n";
 370     print  "ptrsize:      $ptrsize\n";
 371     print  "Byteorder:    $byteorder\n";
 372 }
 373
 374 # check by comparing files line by line
 375 #
 376 print "--- checking ---\n" if $dbg;
 377 $lineno = 0;
 378 my( $asmline, $disline );
 379 while( defined( $asmline = <ASM> ) ){
 380     $disline = <DIS>;
 381     ++$lineno;
 382     last if $lineno eq $firstbadline; # bail out where errors begin
 383     ok( $asmline eq $disline, $descr[$lineno] );
 384     printf "%5d %s\n", $lineno, $asmline if $dbg;
 385 }
 386 close( ASM );
 387 close( DIS );
 388
 389 __END__