Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # -*- perl -*- |
2 | ||
3 | # IMPORTANT: Do not 'use Midas::Test' from anywhere within midas. The | |
4 | # Test::More module will monkey with midas' exit status, so it won't | |
5 | # function properly. Test scripts should: use Midas; use Midas::Test; | |
6 | # explicitly. | |
7 | ||
8 | ||
9 | package Midas::Test; | |
10 | use strict; | |
11 | ||
12 | use TRELoad 'BitFieldTie'; | |
13 | use Test::More; | |
14 | use Midas::MMU::TTEFormat; | |
15 | ||
16 | require Exporter; | |
17 | our @ISA = qw(Exporter); | |
18 | ||
19 | our @Test_functions = qw( | |
20 | check_full_section check_tsb | |
21 | addr_to_entry new_ttehash | |
22 | va2tsbtag ra2tsbdata | |
23 | compact_section parse_mem_image | |
24 | verbose_args dir_args parse_symtab | |
25 | ); | |
26 | ||
27 | our @EXPORT = (@Test_functions, '@Test_functions'); | |
28 | ||
29 | ############################################################################### | |
30 | ||
31 | { | |
32 | package Midas::Test::Memimage; | |
33 | use strict; | |
34 | use fields qw( file sections ); | |
35 | use Test::More; | |
36 | ||
37 | sub new { | |
38 | my $class = shift; | |
39 | my $file = shift; | |
40 | my $this = fields::new($class); | |
41 | $this->{file} = $file if defined $file; | |
42 | $this->{sections} = {}; | |
43 | return $this; | |
44 | } | |
45 | ||
46 | sub debug_print { | |
47 | my $this = shift; | |
48 | ||
49 | print "MEMIMAGE \"$this->{file}\"\n"; | |
50 | foreach my $sec (sort keys %{$this->{sections}}) { | |
51 | print $this->{sections}{$sec}->tostring(); | |
52 | } | |
53 | } | |
54 | ||
55 | sub num_nonzero_secs { | |
56 | my $this = shift; | |
57 | my $num = 0; | |
58 | foreach my $sec (keys %{$this->{sections}}) { | |
59 | my $size = $this->{sections}{$sec}->size(); | |
60 | $num++ if $this->{sections}{$sec}->nonzero_size() > 0; | |
61 | } | |
62 | return $num; | |
63 | } | |
64 | ||
65 | sub num_nonempty_secs { | |
66 | my $this = shift; | |
67 | my $num = 0; | |
68 | foreach my $sec (keys %{$this->{sections}}) { | |
69 | my $size = $this->{sections}{$sec}->size(); | |
70 | $num++ if $this->{sections}{$sec}->size() > 0; | |
71 | } | |
72 | return $num; | |
73 | } | |
74 | ||
75 | ||
76 | sub get_sec_from_pa { | |
77 | my $this = shift; | |
78 | my $pa = shift; | |
79 | ||
80 | return $this->{sections}{$pa} if exists $this->{sections}{$pa}; | |
81 | return; | |
82 | } | |
83 | ||
84 | sub check_full_section { | |
85 | my $this = shift; | |
86 | my $pa = shift; | |
87 | my $elems = shift; | |
88 | my $just_beginning = shift; | |
89 | ||
90 | my $sec = $this->get_sec_from_pa($pa); | |
91 | ok(defined($sec), "Section exists at pa=$pa."); | |
92 | $sec->check_full_sec($elems, $just_beginning) if defined $sec; | |
93 | } | |
94 | ||
95 | sub check_tsb { | |
96 | my $this = shift; | |
97 | my $pa = shift; | |
98 | my $entries = shift; | |
99 | my $tsbname = shift; | |
100 | my $mmutype = shift; | |
101 | ||
102 | my $sec = $this->get_sec_from_pa($pa); | |
103 | ok(defined($sec), "TSB '$tsbname' exists at pa=$pa."); | |
104 | ||
105 | $sec->check_tsb($entries, $mmutype) if defined $sec; | |
106 | } | |
107 | ||
108 | } | |
109 | ||
110 | ############################################################################### | |
111 | ||
112 | { | |
113 | package Midas::Test::MemimageSection; | |
114 | use strict; | |
115 | use fields qw(pa name subsecs); | |
116 | use Test::More; | |
117 | ||
118 | sub new { | |
119 | my $class = shift; | |
120 | my $pa = shift; | |
121 | my $this = fields::new($class); | |
122 | $this->{pa} = $pa if defined $pa; | |
123 | $this->{subsecs} = {}; | |
124 | return $this; | |
125 | } | |
126 | ||
127 | sub size { | |
128 | my $this = shift; | |
129 | my $size = 0; | |
130 | foreach my $subsec (keys %{$this->{subsecs}}) { | |
131 | $size += $this->{subsecs}{$subsec}->size(); | |
132 | } | |
133 | return $size; | |
134 | } | |
135 | ||
136 | sub nonzero_size { | |
137 | my $this = shift; | |
138 | my $size = 0; | |
139 | foreach my $subsec (keys %{$this->{subsecs}}) { | |
140 | $size += $this->{subsecs}{$subsec}->nonzero_size(); | |
141 | } | |
142 | return $size; | |
143 | } | |
144 | ||
145 | sub add_subsec { | |
146 | my $this = shift; | |
147 | my $subsec = shift; | |
148 | $this->{subsecs}{$subsec->{pa}} = $subsec; | |
149 | if($subsec->is_sec_start()) { | |
150 | $this->{pa} = $subsec->{pa}; | |
151 | $this->{name} = $subsec->{comments}; | |
152 | } | |
153 | $subsec->{secname} = $this->{name}; | |
154 | } | |
155 | ||
156 | sub get_index { | |
157 | my $this = shift; | |
158 | my $index = shift; | |
159 | ||
160 | foreach my $subsec (sort keys %{$this->{subsecs}}) { | |
161 | if($index >= $this->{subsecs}{$subsec}{offset_i} and | |
162 | $index < ($this->{subsecs}{$subsec}{offset_i}+ | |
163 | $this->{subsecs}{$subsec}->size())) | |
164 | { | |
165 | my $subindex = $index - $this->{subsecs}{$subsec}{offset_i}; | |
166 | return $this->{subsecs}{$subsec}{data}[$subindex]; | |
167 | } | |
168 | } | |
169 | return; | |
170 | } | |
171 | ||
172 | sub tostring { | |
173 | my $this = shift; | |
174 | my $str = "SECTION \@$this->{pa} $this->{name}\n"; | |
175 | foreach my $subsec (sort keys %{$this->{subsecs}}) { | |
176 | $str .= " " . $this->{subsecs}{$subsec}->tostring(); | |
177 | } | |
178 | return $str; | |
179 | } | |
180 | ||
181 | sub check_full_sec { | |
182 | my $this = shift; | |
183 | my $elems = shift; | |
184 | my $just_beginning = shift; | |
185 | ||
186 | $just_beginning = 0 unless defined $just_beginning; | |
187 | ||
188 | my @subsecs = values %{$this->{subsecs}}; | |
189 | is(@subsecs, 1, "Section '$this->{name}' has no subsections."); | |
190 | $subsecs[0]->check_full_subsec($elems, $just_beginning); | |
191 | } | |
192 | ||
193 | sub check_tsb { | |
194 | my $this = shift; | |
195 | my $entries = shift; | |
196 | my $mmutype = shift; | |
197 | my $name = $this->{name}; | |
198 | ||
199 | my $num_entries = int($this->nonzero_size() / 2); | |
200 | my $expected_num_entries = @$entries; | |
201 | ||
202 | is($num_entries, $expected_num_entries, | |
203 | "Check TSB '$name' has '$expected_num_entries' entries."); | |
204 | ||
205 | foreach my $entry (@$entries) { | |
206 | my $tag_index = $entry->{entry} * 2; | |
207 | my $data_index = $tag_index + 1; | |
208 | ||
209 | my $tag = Midas::Test::va2tsbtag($entry->{va}, $entry->{ttehash}, | |
210 | $mmutype); | |
211 | my $data = Midas::Test::ra2tsbdata($entry->{ra}, $entry->{ttehash}, | |
212 | $mmutype); | |
213 | ||
214 | ok(defined $this->get_index($tag_index), | |
215 | "Check there is a tag for entry $entry->{entry}."); | |
216 | is($this->get_index($tag_index), $tag, | |
217 | "Check the value of tag for entry $entry->{entry} is '$tag'."); | |
218 | ok(defined $this->get_index($data_index), | |
219 | "Check there is a data for entry $entry->{entry}."); | |
220 | is($this->get_index($data_index), $data, | |
221 | "Check the value of data for entry $entry->{entry} is '$data'."); | |
222 | ||
223 | } | |
224 | } | |
225 | ||
226 | } | |
227 | ||
228 | ############################################################################### | |
229 | ||
230 | { | |
231 | package Midas::Test::MemimageSubsec; | |
232 | use strict; | |
233 | use fields qw(pa comments sec secpa data offset_b offset_i secname); | |
234 | use Test::More; | |
235 | ||
236 | sub new { | |
237 | my $class = shift; | |
238 | my $pa = shift; | |
239 | my $comments = shift; | |
240 | ||
241 | my $this = fields::new($class); | |
242 | ||
243 | $this->{pa} = $pa if defined $pa; | |
244 | $this->{comments} = $comments if defined $comments; | |
245 | $this->{data} = []; | |
246 | return $this; | |
247 | } | |
248 | ||
249 | sub size { | |
250 | my $this = shift; | |
251 | return scalar @{$this->{data}}; | |
252 | } | |
253 | ||
254 | sub nonzero_size { | |
255 | my $this = shift; | |
256 | my $nz = 0; | |
257 | foreach my $d (@{$this->{data}}) { | |
258 | $nz++ if $d =~ /[1-9a-fA-F]/; | |
259 | } | |
260 | return $nz; | |
261 | } | |
262 | ||
263 | sub add_data { | |
264 | my $this = shift; | |
265 | my $data = shift; | |
266 | ||
267 | push @{$this->{data}}, @$data; | |
268 | } | |
269 | ||
270 | sub tostring { | |
271 | my $this = shift; | |
272 | my $size = $this->size(); | |
273 | my $str = "SUBSEC \@$this->{pa}: $size elements, offset=$this->{offset_b} bytes, $this->{offset_i} index\n"; | |
274 | return $str; | |
275 | } | |
276 | ||
277 | sub is_sec_start { | |
278 | my $this = shift; | |
279 | return 1 if $this->{secpa} eq $this->{pa}; | |
280 | return 0; | |
281 | } | |
282 | ||
283 | sub calculate_offsets { | |
284 | my $this = shift; | |
285 | ||
286 | my $pa_bf = BitFieldTie->new(64, $this->{pa}); | |
287 | my $sec_pa_bf = BitFieldTie->new(64, $this->{secpa}); | |
288 | ||
289 | $pa_bf->subtract($sec_pa_bf); | |
290 | $this->{offset_b} = $pa_bf->extract(31, 0); | |
291 | $this->{offset_i} = ($pa_bf->extract(31, 0) >> 3); | |
292 | } | |
293 | ||
294 | sub parse_comments { | |
295 | my $this = shift; | |
296 | ||
297 | return unless defined $this->{comments}; | |
298 | if($this->{comments} =~ /Section\s/ or $this->{comments} =~ /TSB\s/ or | |
299 | $this->{comments} =~ /TSB_LINK\s/) { | |
300 | $this->{secpa} = $this->{pa}; | |
301 | } elsif($this->{comments} =~ /from compressed 0x([\da-f]+)/) { | |
302 | $this->{secpa} = $1; | |
303 | } | |
304 | $this->calculate_offsets(); | |
305 | } | |
306 | ||
307 | sub check_full_subsec { | |
308 | my $this = shift; | |
309 | my $elems = shift; | |
310 | my $just_beginning = shift; | |
311 | ||
312 | $just_beginning = 0 unless defined $just_beginning; | |
313 | my $elemsize = @$elems; | |
314 | ||
315 | if(not $just_beginning) { | |
316 | is($this->size(), $elemsize, | |
317 | "sec $this->{secname} has $elemsize elements."); | |
318 | } | |
319 | my $i = 0; | |
320 | foreach my $elem (@$elems) { | |
321 | is($this->{data}[$i], $elem, | |
322 | "Sec $this->{secname}, check element $i."); | |
323 | $i++; | |
324 | } | |
325 | } | |
326 | ||
327 | } | |
328 | ||
329 | ############################################################################### | |
330 | ||
331 | { | |
332 | package Midas::Test::Symtab; | |
333 | use strict; | |
334 | use fields qw(entries); | |
335 | use Test::More; | |
336 | ||
337 | sub new { | |
338 | my $class = shift; | |
339 | my $this = fields::new($class); | |
340 | $this->{entries} = {}; | |
341 | return $this; | |
342 | } | |
343 | ||
344 | sub add_entry { | |
345 | my $this = shift; | |
346 | my $entry = shift; | |
347 | $this->{entries}{$entry->{name}} = $entry; | |
348 | } | |
349 | ||
350 | sub check { | |
351 | my $this = shift; | |
352 | my $list = shift; | |
353 | ||
354 | foreach my $elem (@$list) { | |
355 | my ($name, $va, $ra, $pa) = @$elem; | |
356 | if(not defined $pa) { | |
357 | $pa = $ra; | |
358 | undef $ra; | |
359 | } | |
360 | ||
361 | ok(exists $this->{entries}{$name}, | |
362 | "symbol table entry exists for '$name'"); | |
363 | ||
364 | if(exists $this->{entries}{$name}) { | |
365 | $this->{entries}{$name}->check($va, $ra, $pa); | |
366 | } | |
367 | } | |
368 | ||
369 | } | |
370 | ||
371 | } | |
372 | ||
373 | ############################################################################### | |
374 | ||
375 | { | |
376 | package Midas::Test::SymtabEntry; | |
377 | use strict; | |
378 | use fields qw(name va ra pa); | |
379 | use Test::More; | |
380 | ||
381 | sub new { | |
382 | my $class = shift; | |
383 | my $name = shift; | |
384 | my $va = shift; | |
385 | my $ra = shift; | |
386 | my $pa = shift; | |
387 | my $this = fields::new($class); | |
388 | $this->{name} = $name if defined $name; | |
389 | $this->{va} = $va if defined $va; | |
390 | $this->{ra} = $ra if defined $ra; | |
391 | $this->{pa} = $pa if defined $pa; | |
392 | return $this; | |
393 | } | |
394 | ||
395 | sub check { | |
396 | my $this = shift; | |
397 | my $va = shift; | |
398 | my $ra = shift; | |
399 | my $pa = shift; | |
400 | ||
401 | is($this->{va}, $va, "Check VA in symtab for '$this->{name}' is $va"); | |
402 | if(defined $ra) { | |
403 | is($this->{ra}, $ra, "Check RA in symtab for '$this->{name}' is $ra"); | |
404 | } else { | |
405 | ok(! defined $this->{ra}, | |
406 | "Check RA in symtab for '$this->{name}' is undefined"); | |
407 | } | |
408 | is($this->{pa}, $pa, "Check PA in symtab for '$this->{name}' is $pa"); | |
409 | } | |
410 | ||
411 | } | |
412 | ||
413 | ############################################################################### | |
414 | ||
415 | sub parse_symtab { | |
416 | my $file = shift; | |
417 | my $fh = IO::File->new("<$file"); | |
418 | ||
419 | my $symtab = Midas::Test::Symtab->new(); | |
420 | ||
421 | ok(defined $fh, "Open symbol.tbl"); | |
422 | return $symtab unless defined $fh; | |
423 | ||
424 | ||
425 | while(<$fh>) { | |
426 | if(/^(\S+)\s+(\S+)\s+(\S+)(\s+(\S+))/) { | |
427 | my $name = $1; | |
428 | my $va = $2; | |
429 | my $ra = $3; | |
430 | my $pa = $5; | |
431 | if(not defined $pa) { | |
432 | $pa = $ra; | |
433 | undef $ra; | |
434 | } | |
435 | my $entry = Midas::Test::SymtabEntry->new($name, $va, $ra, $pa); | |
436 | $symtab->add_entry($entry); | |
437 | ||
438 | } | |
439 | ||
440 | } | |
441 | return $symtab; | |
442 | } | |
443 | ||
444 | ############################################################################### | |
445 | ||
446 | sub parse_mem_image { | |
447 | my $file = shift; | |
448 | ||
449 | my $fh = IO::File->new("<$file"); | |
450 | ||
451 | ok(defined $fh, "Open mem.image"); | |
452 | return unless defined $fh; | |
453 | ||
454 | my @subsecs; | |
455 | my $subsec; | |
456 | while(<$fh>) { | |
457 | chomp; | |
458 | next unless /\S/; | |
459 | ||
460 | if(/^\s*\@(0[xX])?([\da-fA-F]+)\s*(\/\/\s*(.*))?/) { | |
461 | my $pa = $2; | |
462 | my $comment = $4; | |
463 | $subsec = Midas::Test::MemimageSubsec->new($pa, $comment); | |
464 | $subsec->parse_comments(); | |
465 | push @subsecs, $subsec; | |
466 | ||
467 | } else { | |
468 | ||
469 | s/\/\/.*$//; | |
470 | next unless /\S/; | |
471 | ||
472 | die "No current subsec!\n" unless defined $subsec; | |
473 | ||
474 | my @nums = split ' '; | |
475 | $subsec->add_data(\@nums); | |
476 | } | |
477 | ||
478 | } | |
479 | ||
480 | my $memimage = Midas::Test::Memimage->new($file); | |
481 | my %sections; | |
482 | foreach my $ss (@subsecs) { | |
483 | if($ss->is_sec_start()) { | |
484 | my $section = Midas::Test::MemimageSection->new(); | |
485 | $sections{$ss->{secpa}} = $section; | |
486 | } | |
487 | die "No section for subsection $ss->{pa}\n" | |
488 | unless exists $sections{$ss->{secpa}}; | |
489 | $sections{$ss->{secpa}}->add_subsec($ss); | |
490 | } | |
491 | ||
492 | $memimage->{sections} = \%sections; | |
493 | # $memimage->debug_print(); | |
494 | ||
495 | return $memimage; | |
496 | } | |
497 | ||
498 | ############################################################################### | |
499 | ||
500 | sub addr_to_entry { | |
501 | my $va = shift; | |
502 | my $pagesize = shift; | |
503 | my $tsbsize = shift; | |
504 | ||
505 | $tsbsize = 0 unless defined $tsbsize; | |
506 | ||
507 | tie my %va, 'BitFieldTie', 64, $va; | |
508 | my $hi = 21 + $tsbsize + 3*$pagesize; | |
509 | my $lo = 13 + 3*$pagesize; | |
510 | my $entry = $va{"$hi:$lo"}; | |
511 | return $entry; | |
512 | } | |
513 | ||
514 | ############################################################################### | |
515 | ||
516 | sub new_ttehash { | |
517 | # union of all tte attributes for all mmus | |
518 | my $h = | |
519 | { | |
520 | tte_v => 1, | |
521 | tte_size => 0, | |
522 | tte_nfo => 0, | |
523 | tte_ie => 0, | |
524 | tte_soft2 => 0, | |
525 | tte_soft => 0, | |
526 | tte_l => 0, | |
527 | tte_cp => 0, | |
528 | tte_cv => 0, | |
529 | tte_e => 0, | |
530 | tte_p => 0, | |
531 | tte_w => 0, | |
532 | tte_g => 0, | |
533 | tte_context => 0, | |
534 | tte_diag => 0, | |
535 | ||
536 | tte_sw0 => 0, | |
537 | tte_sw1 => 0, | |
538 | tte_rsvd0 => 0, | |
539 | tte_ep => 0, | |
540 | tte_rsvd1 => 0, | |
541 | ||
542 | tte_fmt => 'sun4u', | |
543 | tsbtagformat => 'tagaccess', | |
544 | ||
545 | bypass => 0, | |
546 | }; | |
547 | ||
548 | return $h; | |
549 | } | |
550 | ||
551 | ############################################################################### | |
552 | ||
553 | sub va2tsbtag { | |
554 | my $va = shift; | |
555 | my $ttehash = shift; | |
556 | my $mmutype = shift; | |
557 | ||
558 | return $va if $ttehash->{is_link}; | |
559 | my $format = defined $ttehash->{tsbtagfmt} ? | |
560 | $ttehash->{tsbtagfmt} : 'tagaccess'; | |
561 | ||
562 | my $tag = tte_hash_to_tsb_tag($mmutype, $format, $ttehash, | |
563 | $va, 0); | |
564 | $tag = 'XXXXXXXXXXXXXXXX' unless defined $tag; | |
565 | return $tag; | |
566 | } | |
567 | ||
568 | ############################################################################### | |
569 | ||
570 | sub ra2tsbdata { | |
571 | my $ra = shift; | |
572 | my $ttehash = shift; | |
573 | my $mmutype = shift; | |
574 | ||
575 | return $ra if $ttehash->{is_link}; | |
576 | $mmutype = 'niagara' unless defined $mmutype; | |
577 | $mmutype = lc $mmutype; | |
578 | ||
579 | ||
580 | my $data = tte_hash_to_tsb_data($mmutype, $ttehash->{tte_fmt}, | |
581 | $ttehash, $ra); | |
582 | ||
583 | $data = 'XXXXXXXXXXXXXXXX' unless defined $data; | |
584 | return $data; | |
585 | } | |
586 | ||
587 | ||
588 | ############################################################################### | |
589 | ||
590 | sub verbose_args { | |
591 | my $verbose = shift; | |
592 | my $tofile = shift; | |
593 | ||
594 | $tofile = 0 unless defined $tofile; | |
595 | ||
596 | if(not $verbose) { | |
597 | if($tofile) { | |
598 | return qw(-v 2 -print_errors); | |
599 | } else { | |
600 | return qw(-v 0 -noprint_errors); | |
601 | } | |
602 | } else { | |
603 | return qw(-v 2 -print_errors); | |
604 | } | |
605 | } | |
606 | ||
607 | ############################################################################### | |
608 | ||
609 | sub dir_args { | |
610 | my $resultdir = shift; | |
611 | return ('-build_dir', $resultdir, '-dest_dir', $resultdir, '-nocleanup'); | |
612 | } | |
613 | ||
614 | ############################################################################### | |
615 | 1; |