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 | } |
dc9e9a31 |
162 | print "1..0\n"; exit 0; |
ff924b36 |
163 | } |
164 | |
f4abc3e7 |
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 ) = @_; |
e53790c1 |
208 | for my $odt ( sort( keys( %opsByType ) ) ){ |
f4abc3e7 |
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__ |