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