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 svtype      => undef,
 258               );
 259
 260 # Erronous operand values
 261 #
 262 my %badlist = (
 263 comment_t   => [ '"multi-line\ncomment"' ],  # no \n
 264 none        => [ '"spurious arg"'  ],
 265 svindex     => [ 0xffffffff * 2, -1 ],
 266 opindex     => [ 0xffffffff * 2, -2 ],
 267 pvindex     => [ 0xffffffff * 2, -3 ],
 268 U32         => [ 0xffffffff * 2, -4 ],
 269 U16         => [ 0x5ffff, -5 ],
 270 U8          => [ 0x6ff, -6 ],
 271 PV          => [ 'no quote"' ],
 272 I32         => [ -0x80000001, 0x80000000 ],
 273 IV64        => undef, # PUT_IV64 doesn't check - no integrity there
 274 IV          => $Config{ivsize} == 4 ?
 275                [ -0x80000001, 0x80000000 ] : undef,
 276 NV          => undef, # PUT_NV accepts anything - it shouldn't, real-ly
 277 pvcontents  => [ '"spurious arg"' ],
 278 strconst    => [  'no quote"',  '"with NUL '."\0".' char"' ], # no NUL
 279 op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
 280 PADOFFSET   => undef,
 281 long        => undef,
 282 svtype      => undef,
 283               );
 284
 285
 286 # Determine all operand types from %Asmdata::insn_data
 287 #
 288 for my $opname ( keys( %insn_data ) ){
 289     my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
 290     push( @{$opsByType{$getname}}, $opcode );
 291     $code2name[$opcode] = $opname;
 292 }
 293
 294
 295 # Write instruction(s) for correct operand values each operand type class
 296 #
 297 $lineno = 0;
 298 tie( *ASM, 'VirtFile' );
 299 gen_type( \%goodlist, \@descr, 'round trip' );
 300
 301 # Write one instruction for each opcode.
 302 #
 303 for my $opcode ( 0..$#code2name ){
 304     next unless defined( $code2name[$opcode] );
 305     my $sel = $insn_data{$code2name[$opcode]}->[2];
 306     $sel =~ s/^GET_//;
 307     die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
 308     if( defined( $goodlist{$sel} ) ){
 309         ++$lineno;
 310         if( @{$goodlist{$sel}} ){
 311             my $od = $goodlist{$sel}[0];
 312             $descr[$lineno] = "round trip: $code2name[$opcode] $od";
 313             print ASM "$code2name[$opcode] $od\n";
 314             printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
 315         } else {
 316             $descr[$lineno] = "round trip: $code2name[$opcode]";
 317             print ASM "$code2name[$opcode]\n";
 318             printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
 319         }
 320     }
 321 }
 322
 323 # Write instruction(s) for incorrect operand values each operand type class
 324 #
 325 $firstbadline = $lineno + 1;
 326 gen_type( \%badlist, \@descr, 'asm error' );
 327
 328 # invalid opcode is an odd-man-out ;-)
 329 #
 330 ++$lineno;
 331 $descr[$lineno] = "asm error: Gollum";
 332 print ASM "Gollum\n";
 333 printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
 334
 335 close( ASM );
 336
 337 # Now that we have defined all of our tests: plan
 338 #
 339 plan( tests => $lineno );
 340 print "firstbadline=$firstbadline\n" if $dbg;
 341
 342 # assemble (guard against warnings and death from assembly errors)
 343 #
 344 $SIG{'__WARN__'} = \&catchwarn;
 345
 346 $lineno = -1; # account for the assembly header
 347 tie( *OBJ, 'VirtFile' );
 348 eval { assemble_fh( \*ASM, \&putobj ); };
 349 print "eval: $@" if $dbg;
 350 close( ASM );
 351 close( OBJ );
 352 $SIG{'__WARN__'} = 'DEFAULT';
 353
 354 # disassemble
 355 #
 356 print "--- disassembling ---\n" if $dbg;
 357 $lineno = 0;
 358 tie( *DIS, 'VirtFile' );
 359 disassemble_fh( \*OBJ, \&putdis );
 360 close( OBJ );
 361 close( DIS );
 362
 363 # get header (for debugging only)
 364 #
 365 if( $dbg ){
 366     my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
 367         get_header();
 368     printf "Magic:        0x%08x\n", $magic;
 369     print  "Architecture: $archname\n";
 370     print  "Byteloader V: $blversion\n";
 371     print  "ivsize:       $ivsize\n";
 372     print  "ptrsize:      $ptrsize\n";
 373     print  "Byteorder:    $byteorder\n";
 374 }
 375
 376 # check by comparing files line by line
 377 #
 378 print "--- checking ---\n" if $dbg;
 379 $lineno = 0;
 380 my( $asmline, $disline );
 381 while( defined( $asmline = <ASM> ) ){
 382     $disline = <DIS>;
 383     ++$lineno;
 384     last if $lineno eq $firstbadline; # bail out where errors begin
 385     ok( $asmline eq $disline, $descr[$lineno] );
 386     printf "%5d %s\n", $lineno, $asmline if $dbg;
 387 }
 388 close( ASM );
 389 close( DIS );
 390
 391 __END__