This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Byteloader patching from Enache continues;
[perl5.git] / ext / B / t / assembler.t
CommitLineData
f4abc3e7
JH
1#!./perl -w
2
3=pod
4
5=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
6
7=head2 Description
8
9The general idea is to test by assembling a choice set of assembler
10instructions, then disassemble them, and check that we've completed the
11round trip. Also, error checking of Assembler.pm is tested by feeding
12it assorted errors.
13
14Since Assembler.pm likes to assemble a file, we comply by writing a
15text file. This file contains three sections:
16
17 testing operand categories
18 use each opcode
19 erronous assembler instructions
20
21An "operand category" is identified by the suffix of the PUT_/GET_
22subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
23opcode C<ldsv> has operand category C<svindex>:
24
25 insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
26
27Because Disassembler.pm also assumes input from a file, we write the
28resulting object code to a file. And disassembled output is written to
29yet another text file which is then compared to the original input.
30(Erronous assembler instructions still generate code, but this is not
31written to the object file; therefore disassembly bails out at the first
32instruction in error.)
33
34All files are kept in memory by using TIEHASH.
35
36
37=head2 Caveats
38
39An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
40generates invalid object code will not be detected.
41
42Due to the way this test has been set up, failure of a single test
43could cause all subsequent tests to fail as well: After an unexpected
44assembler error no output is written, and disassembled lines will be
45out of sync for all lines thereafter.
46
47Not all possibilities for writing a valid operand value can be tested
48because disassembly results in a uniform representation.
49
50
51=head2 Maintenance
52
53New opcodes are added automatically.
54
55A new operand category will cause this program to die ("no operand list
56for XXX"). The cure is to add suitable entries to C<%goodlist> and
57C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
58happen that the corresponding assembly or disassembly subroutine is
59missing.) Note that an empty array as a C<%goodlist> entry means that
60opcodes of the operand category do not take an operand (and therefore the
61corresponding entry in C<%badlist> should have one). An C<undef> entry
62in C<%badlist> means that any value is acceptable (and thus there is no
63way to cause an error).
64
65Set C<$dbg> to debug this test.
66
67=cut
68
69package VirtFile;
70use 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
75sub TIEHANDLE($;$){
76 my( $class, $data ) = @_;
77 my $obj = { data => defined( $data ) ? $data : '',
78 pos => 0 };
79 return bless( $obj, $class );
80}
81
82sub PRINT($@){
83 my( $self ) = shift;
84 $self->{data} .= join( '', @_ );
85}
86
87sub 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
101sub GETC($){
102 my( $self ) = @_;
103 return undef() if $self->{pos} >= length( $self->{data} );
104 return substr( $self->{data}, $self->{pos}++, 1 );
105}
106
107sub 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
119sub 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
139sub TELL($){
140 my $self = shift();
141 return $self->{pos};
142}
143
144sub CLOSE($){
145 my( $self ) = @_;
146 $self->{pos} = 0;
147}
148
1491;
150
151package main;
152
153use strict;
154use Test::More;
155use Config qw(%Config);
156
ff924b36
CB
157BEGIN {
158 if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
159 print "1..0 # Skip -- Perl configured without ByteLoader module\n";
160 exit 0;
161 }
162}
163
f4abc3e7
JH
164use B::Asmdata qw( %insn_data );
165use B::Assembler qw( &assemble_fh );
166use B::Disassembler qw( &disassemble_fh &get_header );
167
168my( %opsByType, @code2name );
169my( $lineno, $dbg, $firstbadline, @descr );
170$dbg = 0; # debug switch
171
172# $SIG{__WARN__} handler to catch Assembler error messages
173#
174my $warnmsg;
175sub 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#
183sub 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#
194sub 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#
205sub gen_type($$$){
206 my( $href, $descref, $text ) = @_;
e53790c1 207 for my $odt ( sort( keys( %opsByType ) ) ){
f4abc3e7
JH
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#
232my %goodlist = (
233comment_t => [ '"a comment"' ], # no \n
234none => [],
235svindex => [ 0x7fffffff, 0 ],
236opindex => [ 0x7fffffff, 0 ],
237pvindex => [ 0x7fffffff, 0 ],
238U32 => [ 0xffffffff, 0 ],
239U8 => [ 0xff, 0 ],
240PV => [ '""', '"a string"', ],
241I32 => [ -0x80000000, 0x7fffffff ],
242IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
243IV => $Config{ivsize} == 4 ?
244 [ -0x80000000, 0x7fffffff ] :
245 [ '0x000000000', '0x0ffffffff', '0x000000001' ],
246NV => [ 1.23456789E3 ],
247U16 => [ 0xffff, 0 ],
248pvcontents => [],
249strconst => [ '""', '"another string"' ], # no NUL
566ece03 250op_tr_array => [ join( ',', 256, 0..255 ) ],
ca337316 251PADOFFSET => undef,
f4abc3e7
JH
252 );
253
254# Erronous operand values
255#
256my %badlist = (
257comment_t => [ '"multi-line\ncomment"' ], # no \n
258none => [ '"spurious arg"' ],
259svindex => [ 0xffffffff * 2, -1 ],
260opindex => [ 0xffffffff * 2, -2 ],
261pvindex => [ 0xffffffff * 2, -3 ],
262U32 => [ 0xffffffff * 2, -4 ],
263U16 => [ 0x5ffff, -5 ],
264U8 => [ 0x6ff, -6 ],
265PV => [ 'no quote"' ],
266I32 => [ -0x80000001, 0x80000000 ],
267IV64 => undef, # PUT_IV64 doesn't check - no integrity there
268IV => $Config{ivsize} == 4 ?
269 [ -0x80000001, 0x80000000 ] : undef,
270NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
271pvcontents => [ '"spurious arg"' ],
272strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
566ece03 273op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
ca337316 274PADOFFSET => undef,
f4abc3e7
JH
275 );
276
277
278# Determine all operand types from %Asmdata::insn_data
279#
280for my $opname ( keys( %insn_data ) ){
281 my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
282 push( @{$opsByType{$getname}}, $opcode );
283 $code2name[$opcode] = $opname;
284}
285
286
287# Write instruction(s) for correct operand values each operand type class
288#
289$lineno = 0;
290tie( *ASM, 'VirtFile' );
291gen_type( \%goodlist, \@descr, 'round trip' );
292
293# Write one instruction for each opcode.
294#
295for my $opcode ( 0..$#code2name ){
296 next unless defined( $code2name[$opcode] );
297 my $sel = $insn_data{$code2name[$opcode]}->[2];
298 $sel =~ s/^GET_//;
299 die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
300 if( defined( $goodlist{$sel} ) ){
301 ++$lineno;
302 if( @{$goodlist{$sel}} ){
303 my $od = $goodlist{$sel}[0];
304 $descr[$lineno] = "round trip: $code2name[$opcode] $od";
305 print ASM "$code2name[$opcode] $od\n";
306 printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
307 } else {
308 $descr[$lineno] = "round trip: $code2name[$opcode]";
309 print ASM "$code2name[$opcode]\n";
310 printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
311 }
312 }
313}
314
315# Write instruction(s) for incorrect operand values each operand type class
316#
317$firstbadline = $lineno + 1;
318gen_type( \%badlist, \@descr, 'asm error' );
319
320# invalid opcode is an odd-man-out ;-)
321#
322++$lineno;
323$descr[$lineno] = "asm error: Gollum";
324print ASM "Gollum\n";
325printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
326
327close( ASM );
328
329# Now that we have defined all of our tests: plan
330#
331plan( tests => $lineno );
332print "firstbadline=$firstbadline\n" if $dbg;
333
334# assemble (guard against warnings and death from assembly errors)
335#
336$SIG{'__WARN__'} = \&catchwarn;
337
338$lineno = -1; # account for the assembly header
339tie( *OBJ, 'VirtFile' );
340eval { assemble_fh( \*ASM, \&putobj ); };
341print "eval: $@" if $dbg;
342close( ASM );
343close( OBJ );
344$SIG{'__WARN__'} = 'DEFAULT';
345
346# disassemble
347#
348print "--- disassembling ---\n" if $dbg;
349$lineno = 0;
350tie( *DIS, 'VirtFile' );
351disassemble_fh( \*OBJ, \&putdis );
352close( OBJ );
353close( DIS );
354
355# get header (for debugging only)
356#
357if( $dbg ){
358 my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
359 get_header();
360 printf "Magic: 0x%08x\n", $magic;
361 print "Architecture: $archname\n";
362 print "Byteloader V: $blversion\n";
363 print "ivsize: $ivsize\n";
364 print "ptrsize: $ptrsize\n";
365 print "Byteorder: $byteorder\n";
366}
367
368# check by comparing files line by line
369#
370print "--- checking ---\n" if $dbg;
371$lineno = 0;
372my( $asmline, $disline );
373while( defined( $asmline = <ASM> ) ){
374 $disline = <DIS>;
375 ++$lineno;
376 last if $lineno eq $firstbadline; # bail out where errors begin
377 ok( $asmline eq $disline, $descr[$lineno] );
378 printf "%5d %s\n", $lineno, $asmline if $dbg;
379}
380close( ASM );
381close( DIS );
382
383__END__