| Commit | Line | Data |
|---|
| f4abc3e7 |
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 | |
| ff924b36 |
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 | |
| f4abc3e7 |
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 ) = @_; |
| e53790c1 |
207 | for my $odt ( sort( keys( %opsByType ) ) ){ |
| f4abc3e7 |
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 |
| 566ece03 |
250 | op_tr_array => [ join( ',', 256, 0..255 ) ], |
| ca337316 |
251 | PADOFFSET => undef, |
| 53897bd5 |
252 | long => undef, |
| f4abc3e7 |
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 |
| 566ece03 |
274 | op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts |
| ca337316 |
275 | PADOFFSET => undef, |
| 53897bd5 |
276 | long => undef, |
| f4abc3e7 |
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__ |
projects / p5sagit/p5-mst-13.2.git / blame