1N/A#!./perl -w
1N/A
1N/A=pod
1N/A
1N/A=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
1N/A
1N/A=head2 Description
1N/A
1N/AThe general idea is to test by assembling a choice set of assembler
1N/Ainstructions, then disassemble them, and check that we've completed the
1N/Around trip. Also, error checking of Assembler.pm is tested by feeding
1N/Ait assorted errors.
1N/A
1N/ASince Assembler.pm likes to assemble a file, we comply by writing a
1N/Atext file. This file contains three sections:
1N/A
1N/A testing operand categories
1N/A use each opcode
1N/A erronous assembler instructions
1N/A
1N/AAn "operand category" is identified by the suffix of the PUT_/GET_
1N/Asubroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
1N/Aopcode C<ldsv> has operand category C<svindex>:
1N/A
1N/A insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
1N/A
1N/ABecause Disassembler.pm also assumes input from a file, we write the
1N/Aresulting object code to a file. And disassembled output is written to
1N/Ayet another text file which is then compared to the original input.
1N/A(Erronous assembler instructions still generate code, but this is not
1N/Awritten to the object file; therefore disassembly bails out at the first
1N/Ainstruction in error.)
1N/A
1N/AAll files are kept in memory by using TIEHASH.
1N/A
1N/A
1N/A=head2 Caveats
1N/A
1N/AAn error where Assembler.pm and Disassembler.pm agree but Assembler.pm
1N/Agenerates invalid object code will not be detected.
1N/A
1N/ADue to the way this test has been set up, failure of a single test
1N/Acould cause all subsequent tests to fail as well: After an unexpected
1N/Aassembler error no output is written, and disassembled lines will be
1N/Aout of sync for all lines thereafter.
1N/A
1N/ANot all possibilities for writing a valid operand value can be tested
1N/Abecause disassembly results in a uniform representation.
1N/A
1N/A
1N/A=head2 Maintenance
1N/A
1N/ANew opcodes are added automatically.
1N/A
1N/AA new operand category will cause this program to die ("no operand list
1N/Afor XXX"). The cure is to add suitable entries to C<%goodlist> and
1N/AC<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
1N/Ahappen that the corresponding assembly or disassembly subroutine is
1N/Amissing.) Note that an empty array as a C<%goodlist> entry means that
1N/Aopcodes of the operand category do not take an operand (and therefore the
1N/Acorresponding entry in C<%badlist> should have one). An C<undef> entry
1N/Ain C<%badlist> means that any value is acceptable (and thus there is no
1N/Away to cause an error).
1N/A
1N/ASet C<$dbg> to debug this test.
1N/A
1N/A=cut
1N/A
1N/Apackage VirtFile;
1N/Ause strict;
1N/A
1N/A# Note: This is NOT a general purpose package. It implements
1N/A# sequential text and binary file i/o in a rather simple form.
1N/A
1N/Asub TIEHANDLE($;$){
1N/A my( $class, $data ) = @_;
1N/A my $obj = { data => defined( $data ) ? $data : '',
1N/A pos => 0 };
1N/A return bless( $obj, $class );
1N/A}
1N/A
1N/Asub PRINT($@){
1N/A my( $self ) = shift;
1N/A $self->{data} .= join( '', @_ );
1N/A}
1N/A
1N/Asub WRITE($$;$$){
1N/A my( $self, $buf, $len, $offset ) = @_;
1N/A unless( defined( $len ) ){
1N/A $len = length( $buf );
1N/A $offset = 0;
1N/A }
1N/A unless( defined( $offset ) ){
1N/A $offset = 0;
1N/A }
1N/A $self->{data} .= substr( $buf, $offset, $len );
1N/A return $len;
1N/A}
1N/A
1N/A
1N/Asub GETC($){
1N/A my( $self ) = @_;
1N/A return undef() if $self->{pos} >= length( $self->{data} );
1N/A return substr( $self->{data}, $self->{pos}++, 1 );
1N/A}
1N/A
1N/Asub READLINE($){
1N/A my( $self ) = @_;
1N/A return undef() if $self->{pos} >= length( $self->{data} );
1N/A my $lfpos = index( $self->{data}, "\n", $self->{pos} );
1N/A if( $lfpos < 0 ){
1N/A $lfpos = length( $self->{data} );
1N/A }
1N/A my $pos = $self->{pos};
1N/A $self->{pos} = $lfpos + 1;
1N/A return substr( $self->{data}, $pos, $self->{pos} - $pos );
1N/A}
1N/A
1N/Asub READ($@){
1N/A my $self = shift();
1N/A my $bufref = \$_[0];
1N/A my( undef, $len, $offset ) = @_;
1N/A if( $offset ){
1N/A die( "offset beyond end of buffer\n" )
1N/A if ! defined( $$bufref ) || $offset > length( $$bufref );
1N/A } else {
1N/A $$bufref = '';
1N/A $offset = 0;
1N/A }
1N/A my $remlen = length( $self->{data} ) - $self->{pos};
1N/A $len = $remlen if $remlen < $len;
1N/A return 0 unless $len;
1N/A substr( $$bufref, $offset, $len ) =
1N/A substr( $self->{data}, $self->{pos}, $len );
1N/A $self->{pos} += $len;
1N/A return $len;
1N/A}
1N/A
1N/Asub TELL($){
1N/A my $self = shift();
1N/A return $self->{pos};
1N/A}
1N/A
1N/Asub CLOSE($){
1N/A my( $self ) = @_;
1N/A $self->{pos} = 0;
1N/A}
1N/A
1N/A1;
1N/A
1N/Apackage main;
1N/A
1N/Ause strict;
1N/Ause Test::More;
1N/Ause Config qw(%Config);
1N/A
1N/ABEGIN {
1N/A if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
1N/A print "1..0 # Skip -- Perl configured without ByteLoader module\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/Ause B::Asmdata qw( %insn_data );
1N/Ause B::Assembler qw( &assemble_fh );
1N/Ause B::Disassembler qw( &disassemble_fh &get_header );
1N/A
1N/Amy( %opsByType, @code2name );
1N/Amy( $lineno, $dbg, $firstbadline, @descr );
1N/A$dbg = 0; # debug switch
1N/A
1N/A# $SIG{__WARN__} handler to catch Assembler error messages
1N/A#
1N/Amy $warnmsg;
1N/Asub catchwarn($){
1N/A $warnmsg = $_[0];
1N/A print "error: $warnmsg\n" if $dbg;
1N/A}
1N/A
1N/A# Callback for writing assembled bytes. This is where we check
1N/A# that we do get an error.
1N/A#
1N/Asub putobj($){
1N/A if( ++$lineno >= $firstbadline ){
1N/A ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
1N/A undef( $warnmsg );
1N/A } else {
1N/A my $l = syswrite( OBJ, $_[0] );
1N/A }
1N/A}
1N/A
1N/A# Callback for writing a disassembled statement.
1N/A#
1N/Asub putdis(@){
1N/A my $line = join( ' ', @_ );
1N/A ++$lineno;
1N/A print DIS "$line\n";
1N/A printf "%5d %s\n", $lineno, $line if $dbg;
1N/A}
1N/A
1N/A# Generate assembler instructions from a hash of operand types: each
1N/A# existing entry contains a list of good or bad operand values. The
1N/A# corresponding opcodes can be found in %opsByType.
1N/A#
1N/Asub gen_type($$$){
1N/A my( $href, $descref, $text ) = @_;
1N/A for my $odt ( sort( keys( %opsByType ) ) ){
1N/A my $opcode = $opsByType{$odt}->[0];
1N/A my $sel = $odt;
1N/A $sel =~ s/^GET_//;
1N/A die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
1N/A if( defined( $href->{$sel} ) ){
1N/A if( @{$href->{$sel}} ){
1N/A for my $od ( @{$href->{$sel}} ){
1N/A ++$lineno;
1N/A $descref->[$lineno] = "$text: $code2name[$opcode] $od";
1N/A print ASM "$code2name[$opcode] $od\n";
1N/A printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
1N/A }
1N/A } else {
1N/A ++$lineno;
1N/A $descref->[$lineno] = "$text: $code2name[$opcode]";
1N/A print ASM "$code2name[$opcode]\n";
1N/A printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
1N/A }
1N/A }
1N/A }
1N/A}
1N/A
1N/A# Interesting operand values
1N/A#
1N/Amy %goodlist = (
1N/Acomment_t => [ '"a comment"' ], # no \n
1N/Anone => [],
1N/Asvindex => [ 0x7fffffff, 0 ],
1N/Aopindex => [ 0x7fffffff, 0 ],
1N/Apvindex => [ 0x7fffffff, 0 ],
1N/AU32 => [ 0xffffffff, 0 ],
1N/AU8 => [ 0xff, 0 ],
1N/APV => [ '""', '"a string"', ],
1N/AI32 => [ -0x80000000, 0x7fffffff ],
1N/AIV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
1N/AIV => $Config{ivsize} == 4 ?
1N/A [ -0x80000000, 0x7fffffff ] :
1N/A [ '0x000000000', '0x0ffffffff', '0x000000001' ],
1N/ANV => [ 1.23456789E3 ],
1N/AU16 => [ 0xffff, 0 ],
1N/Apvcontents => [],
1N/Astrconst => [ '""', '"another string"' ], # no NUL
1N/Aop_tr_array => [ join( ',', 256, 0..255 ) ],
1N/APADOFFSET => undef,
1N/Along => undef,
1N/A );
1N/A
1N/A# Erronous operand values
1N/A#
1N/Amy %badlist = (
1N/Acomment_t => [ '"multi-line\ncomment"' ], # no \n
1N/Anone => [ '"spurious arg"' ],
1N/Asvindex => [ 0xffffffff * 2, -1 ],
1N/Aopindex => [ 0xffffffff * 2, -2 ],
1N/Apvindex => [ 0xffffffff * 2, -3 ],
1N/AU32 => [ 0xffffffff * 2, -4 ],
1N/AU16 => [ 0x5ffff, -5 ],
1N/AU8 => [ 0x6ff, -6 ],
1N/APV => [ 'no quote"' ],
1N/AI32 => [ -0x80000001, 0x80000000 ],
1N/AIV64 => undef, # PUT_IV64 doesn't check - no integrity there
1N/AIV => $Config{ivsize} == 4 ?
1N/A [ -0x80000001, 0x80000000 ] : undef,
1N/ANV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
1N/Apvcontents => [ '"spurious arg"' ],
1N/Astrconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
1N/Aop_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
1N/APADOFFSET => undef,
1N/Along => undef,
1N/A );
1N/A
1N/A
1N/A# Determine all operand types from %Asmdata::insn_data
1N/A#
1N/Afor my $opname ( keys( %insn_data ) ){
1N/A my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
1N/A push( @{$opsByType{$getname}}, $opcode );
1N/A $code2name[$opcode] = $opname;
1N/A}
1N/A
1N/A
1N/A# Write instruction(s) for correct operand values each operand type class
1N/A#
1N/A$lineno = 0;
1N/Atie( *ASM, 'VirtFile' );
1N/Agen_type( \%goodlist, \@descr, 'round trip' );
1N/A
1N/A# Write one instruction for each opcode.
1N/A#
1N/Afor my $opcode ( 0..$#code2name ){
1N/A next unless defined( $code2name[$opcode] );
1N/A my $sel = $insn_data{$code2name[$opcode]}->[2];
1N/A $sel =~ s/^GET_//;
1N/A die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
1N/A if( defined( $goodlist{$sel} ) ){
1N/A ++$lineno;
1N/A if( @{$goodlist{$sel}} ){
1N/A my $od = $goodlist{$sel}[0];
1N/A $descr[$lineno] = "round trip: $code2name[$opcode] $od";
1N/A print ASM "$code2name[$opcode] $od\n";
1N/A printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
1N/A } else {
1N/A $descr[$lineno] = "round trip: $code2name[$opcode]";
1N/A print ASM "$code2name[$opcode]\n";
1N/A printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
1N/A }
1N/A }
1N/A}
1N/A
1N/A# Write instruction(s) for incorrect operand values each operand type class
1N/A#
1N/A$firstbadline = $lineno + 1;
1N/Agen_type( \%badlist, \@descr, 'asm error' );
1N/A
1N/A# invalid opcode is an odd-man-out ;-)
1N/A#
1N/A++$lineno;
1N/A$descr[$lineno] = "asm error: Gollum";
1N/Aprint ASM "Gollum\n";
1N/Aprintf "%5d %s\n", $lineno, 'Gollum' if $dbg;
1N/A
1N/Aclose( ASM );
1N/A
1N/A# Now that we have defined all of our tests: plan
1N/A#
1N/Aplan( tests => $lineno );
1N/Aprint "firstbadline=$firstbadline\n" if $dbg;
1N/A
1N/A# assemble (guard against warnings and death from assembly errors)
1N/A#
1N/A$SIG{'__WARN__'} = \&catchwarn;
1N/A
1N/A$lineno = -1; # account for the assembly header
1N/Atie( *OBJ, 'VirtFile' );
1N/Aeval { assemble_fh( \*ASM, \&putobj ); };
1N/Aprint "eval: $@" if $dbg;
1N/Aclose( ASM );
1N/Aclose( OBJ );
1N/A$SIG{'__WARN__'} = 'DEFAULT';
1N/A
1N/A# disassemble
1N/A#
1N/Aprint "--- disassembling ---\n" if $dbg;
1N/A$lineno = 0;
1N/Atie( *DIS, 'VirtFile' );
1N/Adisassemble_fh( \*OBJ, \&putdis );
1N/Aclose( OBJ );
1N/Aclose( DIS );
1N/A
1N/A# get header (for debugging only)
1N/A#
1N/Aif( $dbg ){
1N/A my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
1N/A get_header();
1N/A printf "Magic: 0x%08x\n", $magic;
1N/A print "Architecture: $archname\n";
1N/A print "Byteloader V: $blversion\n";
1N/A print "ivsize: $ivsize\n";
1N/A print "ptrsize: $ptrsize\n";
1N/A print "Byteorder: $byteorder\n";
1N/A}
1N/A
1N/A# check by comparing files line by line
1N/A#
1N/Aprint "--- checking ---\n" if $dbg;
1N/A$lineno = 0;
1N/Amy( $asmline, $disline );
1N/Awhile( defined( $asmline = <ASM> ) ){
1N/A $disline = <DIS>;
1N/A ++$lineno;
1N/A last if $lineno eq $firstbadline; # bail out where errors begin
1N/A ok( $asmline eq $disline, $descr[$lineno] );
1N/A printf "%5d %s\n", $lineno, $asmline if $dbg;
1N/A}
1N/Aclose( ASM );
1N/Aclose( DIS );
1N/A
1N/A__END__