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