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