[OpenSPARC-T2-DV] / tools / perlmod / Midas / 3.32 / lib / site_perl / 5.8.0 / Midas / Test.pm

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: Test.pm
# Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved
# 4150 Network Circle, Santa Clara, California 95054, U.S.A.
#
# * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# For the avoidance of doubt, and except that if any non-GPL license 
# choice is available it will apply instead, Sun elects to use only 
# the General Public License version 2 (GPLv2) at this time for any 
# software where a choice of GPL license versions is made 
# available with the language indicating that GPLv2 or any later version 
# may be used, or where a choice of which version of the GPL is applied is 
# otherwise unspecified. 
#
# Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, 
# CA 95054 USA or visit www.sun.com if you need additional information or 
# have any questions. 
# 
# ========== Copyright Header End ============================================
# -*- perl -*-

# IMPORTANT: Do not 'use Midas::Test' from anywhere within midas.  The
# Test::More module will monkey with midas' exit status, so it won't
# function properly.  Test scripts should: use Midas; use Midas::Test;
# explicitly.


package Midas::Test;
use strict;

use TRELoad 'BitFieldTie';
use Test::More;
use Midas::MMU::TTEFormat;

require Exporter;
our @ISA = qw(Exporter);

our @Test_functions = qw(
			 check_full_section check_tsb
			 addr_to_entry new_ttehash
			 va2tsbtag ra2tsbdata
			 compact_section parse_mem_image
			 verbose_args dir_args parse_symtab
			);

our @EXPORT = (@Test_functions, '@Test_functions');

###############################################################################

{
  package Midas::Test::Memimage;
  use strict;
  use fields qw( file sections );
  use Test::More;

  sub new {
    my $class = shift;
    my $file  = shift;
    my $this  = fields::new($class);
    $this->{file}      = $file if defined $file;
    $this->{sections}  = {};
    return $this;
  }

  sub debug_print {
    my $this = shift;

    print "MEMIMAGE \"$this->{file}\"\n";
    foreach my $sec (sort keys %{$this->{sections}}) {
      print $this->{sections}{$sec}->tostring();
    }
  }

  sub num_nonzero_secs {
    my $this = shift;
    my $num = 0;
    foreach my $sec (keys %{$this->{sections}}) {
      my $size = $this->{sections}{$sec}->size();
      $num++ if $this->{sections}{$sec}->nonzero_size() > 0;
    }
    return $num;
  }

  sub num_nonempty_secs {
    my $this = shift;
    my $num = 0;
    foreach my $sec (keys %{$this->{sections}}) {
      my $size = $this->{sections}{$sec}->size();
      $num++ if $this->{sections}{$sec}->size() > 0;
    }
    return $num;
  }


  sub get_sec_from_pa {
    my $this = shift;
    my $pa   = shift;

    return $this->{sections}{$pa} if exists $this->{sections}{$pa};
    return;
  }

  sub check_full_section {
    my $this           = shift;
    my $pa             = shift;
    my $elems          = shift;
    my $just_beginning = shift;

    my $sec = $this->get_sec_from_pa($pa);
    ok(defined($sec), "Section exists at pa=$pa.");
    $sec->check_full_sec($elems, $just_beginning) if defined $sec;
  }

  sub check_tsb {
    my $this = shift;
    my $pa   = shift;
    my $entries = shift;
    my $tsbname = shift;
    my $mmutype = shift;

    my $sec = $this->get_sec_from_pa($pa);
    ok(defined($sec), "TSB '$tsbname' exists at pa=$pa.");

    $sec->check_tsb($entries, $mmutype) if defined $sec;
  }

}

###############################################################################

{
  package Midas::Test::MemimageSection;
  use strict;
  use fields qw(pa name subsecs);
  use Test::More;

  sub new {
    my $class = shift;
    my $pa    = shift;
    my $this  = fields::new($class);
    $this->{pa}      = $pa if defined $pa;
    $this->{subsecs} = {};
    return $this;
  }

  sub size {
    my $this = shift;
    my $size = 0;
    foreach my $subsec (keys %{$this->{subsecs}}) {
      $size += $this->{subsecs}{$subsec}->size();
    }
    return $size;
  }

  sub nonzero_size {
    my $this = shift;
    my $size = 0;
    foreach my $subsec (keys %{$this->{subsecs}}) {
      $size += $this->{subsecs}{$subsec}->nonzero_size();
    }
    return $size;
  }

  sub add_subsec {
    my $this = shift;
    my $subsec = shift;
    $this->{subsecs}{$subsec->{pa}} = $subsec;
    if($subsec->is_sec_start()) {
      $this->{pa}   = $subsec->{pa};
      $this->{name} = $subsec->{comments};
    }
    $subsec->{secname} = $this->{name};
  }

  sub get_index {
    my $this = shift;
    my $index = shift;

    foreach my $subsec (sort keys %{$this->{subsecs}}) {
      if($index >= $this->{subsecs}{$subsec}{offset_i} and
	 $index <  ($this->{subsecs}{$subsec}{offset_i}+
		    $this->{subsecs}{$subsec}->size()))
	{
	  my $subindex = $index - $this->{subsecs}{$subsec}{offset_i};
	  return $this->{subsecs}{$subsec}{data}[$subindex];
	}
    }
    return;
  }

  sub tostring {
    my $this = shift;
    my $str = "SECTION \@$this->{pa} $this->{name}\n";
    foreach my $subsec (sort keys %{$this->{subsecs}}) {
      $str .= "  " . $this->{subsecs}{$subsec}->tostring();
    }
    return $str;
  }

  sub check_full_sec {
    my $this = shift;
    my $elems = shift;
    my $just_beginning = shift;

    $just_beginning = 0 unless defined $just_beginning;

    my @subsecs = values %{$this->{subsecs}};
    is(@subsecs, 1, "Section '$this->{name}' has no subsections.");
    $subsecs[0]->check_full_subsec($elems, $just_beginning);
  }

  sub check_tsb {
    my $this = shift;
    my $entries = shift;
    my $mmutype = shift;
    my $name = $this->{name};

    my $num_entries = int($this->nonzero_size() / 2);
    my $expected_num_entries = @$entries;

    is($num_entries, $expected_num_entries,
       "Check TSB '$name' has '$expected_num_entries' entries.");

    foreach my $entry (@$entries) {
      my $tag_index  = $entry->{entry} * 2;
      my $data_index = $tag_index + 1;

      my $tag  = Midas::Test::va2tsbtag($entry->{va}, $entry->{ttehash},
					$mmutype);
      my $data = Midas::Test::ra2tsbdata($entry->{ra}, $entry->{ttehash},
					 $mmutype);

      ok(defined $this->get_index($tag_index),
	 "Check there is a tag for entry $entry->{entry}.");
      is($this->get_index($tag_index), $tag,
	 "Check the value of tag for entry $entry->{entry} is '$tag'.");
      ok(defined $this->get_index($data_index),
	 "Check there is a data for entry $entry->{entry}.");
      is($this->get_index($data_index), $data,
	 "Check the value of data for entry $entry->{entry} is '$data'.");

    }
  }

}

###############################################################################

{
  package Midas::Test::MemimageSubsec;
  use strict;
  use fields qw(pa comments sec secpa data offset_b offset_i secname);
  use Test::More;

  sub new {
    my $class    = shift;
    my $pa       = shift;
    my $comments = shift;

    my $this  = fields::new($class);

    $this->{pa}       = $pa       if defined $pa;
    $this->{comments} = $comments if defined $comments;
    $this->{data}     = [];
    return $this;
  }

  sub size {
    my $this = shift;
    return scalar @{$this->{data}};
  }

  sub nonzero_size {
    my $this = shift;
    my $nz = 0;
    foreach my $d (@{$this->{data}}) {
      $nz++ if $d =~ /[1-9a-fA-F]/;
    }
    return $nz;
  }

  sub add_data {
    my $this = shift;
    my $data = shift;

    push @{$this->{data}}, @$data;
  }

  sub tostring {
    my $this = shift;
    my $size = $this->size();
    my $str  = "SUBSEC \@$this->{pa}: $size elements, offset=$this->{offset_b} bytes, $this->{offset_i} index\n";
    return $str;
  }

  sub is_sec_start {
    my $this = shift;
    return 1 if $this->{secpa} eq $this->{pa};
    return 0;
  }

  sub calculate_offsets {
    my $this = shift;

    my $pa_bf     = BitFieldTie->new(64, $this->{pa});
    my $sec_pa_bf = BitFieldTie->new(64, $this->{secpa});

    $pa_bf->subtract($sec_pa_bf);
    $this->{offset_b} = $pa_bf->extract(31, 0);
    $this->{offset_i} = ($pa_bf->extract(31, 0) >> 3);
  }

  sub parse_comments {
    my $this = shift;

    return unless defined $this->{comments};
    if($this->{comments} =~ /Section\s/ or $this->{comments} =~ /TSB\s/ or
       $this->{comments} =~ /TSB_LINK\s/) {
      $this->{secpa} = $this->{pa};
    } elsif($this->{comments} =~ /from compressed 0x([\da-f]+)/) {
      $this->{secpa} = $1;
    }
    $this->calculate_offsets();
  }

  sub check_full_subsec {
    my $this  = shift;
    my $elems = shift;
    my $just_beginning = shift;

    $just_beginning = 0 unless defined $just_beginning;
    my $elemsize = @$elems;

    if(not $just_beginning) {
      is($this->size(), $elemsize,
	 "sec $this->{secname} has $elemsize elements.");
    }
    my $i = 0;
    foreach my $elem (@$elems) {
      is($this->{data}[$i], $elem,
	 "Sec $this->{secname}, check element $i.");
      $i++;
    }
  }

}

###############################################################################

{
  package Midas::Test::Symtab;
  use strict;
  use fields qw(entries);
  use Test::More;

  sub new {
    my $class = shift;
    my $this  = fields::new($class);
    $this->{entries} = {};
    return $this;
  }

  sub add_entry {
    my $this = shift;
    my $entry = shift;
    $this->{entries}{$entry->{name}} = $entry;
  }

  sub check {
    my $this = shift;
    my $list = shift;

    foreach my $elem (@$list) {
      my ($name, $va, $ra, $pa) = @$elem;
      if(not defined $pa) {
	$pa = $ra;
	undef $ra;
      }

      ok(exists $this->{entries}{$name},
	 "symbol table entry exists for '$name'");

      if(exists $this->{entries}{$name}) {
	$this->{entries}{$name}->check($va, $ra, $pa);
      }
    }

  }

}

###############################################################################

{
  package Midas::Test::SymtabEntry;
  use strict;
  use fields qw(name va ra pa);
  use Test::More;

  sub new {
    my $class = shift;
    my $name = shift;
    my $va = shift;
    my $ra = shift;
    my $pa = shift;
    my $this  = fields::new($class);
    $this->{name} = $name if defined $name;
    $this->{va} = $va if defined $va;
    $this->{ra} = $ra if defined $ra;
    $this->{pa} = $pa if defined $pa;
    return $this;
  }

  sub check {
    my $this = shift;
    my $va = shift;
    my $ra = shift;
    my $pa = shift;

    is($this->{va}, $va, "Check VA in symtab for '$this->{name}' is $va");
    if(defined $ra) {
      is($this->{ra}, $ra, "Check RA  in symtab for '$this->{name}' is $ra");
    } else {
      ok(! defined $this->{ra}, 
	 "Check RA in symtab for '$this->{name}' is undefined");
    }
    is($this->{pa}, $pa, "Check PA in symtab for '$this->{name}' is $pa");
  }

}

###############################################################################

sub parse_symtab {
  my $file = shift;
  my $fh = IO::File->new("<$file");

  my $symtab = Midas::Test::Symtab->new();

  ok(defined $fh, "Open symbol.tbl");
  return $symtab unless defined $fh;


  while(<$fh>) {
    if(/^(\S+)\s+(\S+)\s+(\S+)(\s+(\S+))/) {
      my $name = $1;
      my $va = $2;
      my $ra = $3;
      my $pa = $5;
      if(not defined $pa) {
	$pa = $ra;
	undef $ra;
      }
      my $entry = Midas::Test::SymtabEntry->new($name, $va, $ra, $pa);
      $symtab->add_entry($entry);

    }

  }
  return $symtab;
}

###############################################################################

sub parse_mem_image {
  my $file = shift;

  my $fh = IO::File->new("<$file");

  ok(defined $fh, "Open mem.image");
  return unless defined $fh;

  my @subsecs;
  my $subsec;
  while(<$fh>) {
    chomp;
    next unless /\S/;

    if(/^\s*\@(0[xX])?([\da-fA-F]+)\s*(\/\/\s*(.*))?/) {
      my $pa = $2;
      my $comment = $4;
      $subsec = Midas::Test::MemimageSubsec->new($pa, $comment);
      $subsec->parse_comments();
      push @subsecs, $subsec;

    } else {

      s/\/\/.*$//;
      next unless /\S/;

      die "No current subsec!\n" unless defined $subsec;

      my @nums = split ' ';
      $subsec->add_data(\@nums);
    }

  }

  my $memimage = Midas::Test::Memimage->new($file);
  my %sections;
  foreach my $ss (@subsecs) {
    if($ss->is_sec_start()) {
      my $section = Midas::Test::MemimageSection->new();
      $sections{$ss->{secpa}} = $section;
    }
    die "No section for subsection $ss->{pa}\n"
      unless exists $sections{$ss->{secpa}};
    $sections{$ss->{secpa}}->add_subsec($ss);
  }

  $memimage->{sections} = \%sections;
#  $memimage->debug_print();

  return $memimage;
}

###############################################################################

sub addr_to_entry {
  my $va = shift;
  my $pagesize = shift;
  my $tsbsize = shift;

  $tsbsize = 0 unless defined $tsbsize;

  tie my %va, 'BitFieldTie', 64, $va;
  my $hi = 21 + $tsbsize + 3*$pagesize;
  my $lo = 13 + 3*$pagesize;
  my $entry = $va{"$hi:$lo"};
  return $entry;
}

###############################################################################

sub new_ttehash {
  # union of all tte attributes for all mmus
  my $h =
    {
     tte_v => 1,
     tte_size => 0,
     tte_nfo => 0,
     tte_ie => 0,
     tte_soft2 => 0,
     tte_soft => 0,
     tte_l => 0,
     tte_cp => 0,
     tte_cv => 0,
     tte_e => 0,
     tte_p => 0,
     tte_w => 0,
     tte_g => 0,
     tte_context => 0,
     tte_diag => 0,

     tte_sw0 => 0,
     tte_sw1 => 0,
     tte_rsvd0 => 0,
     tte_ep    => 0,
     tte_rsvd1 => 0,

     tte_fmt => 'sun4u',
     tsbtagformat => 'tagaccess',

     bypass => 0,
    };

  return $h;
}

###############################################################################

sub va2tsbtag {
  my $va = shift;
  my $ttehash = shift;
  my $mmutype = shift;

  return $va if $ttehash->{is_link};
  my $format = defined $ttehash->{tsbtagfmt} ?
    $ttehash->{tsbtagfmt} : 'tagaccess';

  my $tag = tte_hash_to_tsb_tag($mmutype, $format, $ttehash,
				$va, 0);
  $tag = 'XXXXXXXXXXXXXXXX' unless defined $tag;
  return $tag;
}

###############################################################################

sub ra2tsbdata {
  my $ra      = shift;
  my $ttehash = shift;
  my $mmutype = shift;

  return $ra if $ttehash->{is_link};
  $mmutype = 'niagara' unless defined $mmutype;
  $mmutype = lc $mmutype;


  my $data = tte_hash_to_tsb_data($mmutype, $ttehash->{tte_fmt},
				  $ttehash, $ra);

  $data = 'XXXXXXXXXXXXXXXX' unless defined $data;
  return $data;
}


###############################################################################

sub verbose_args {
  my $verbose = shift;
  my $tofile = shift;

  $tofile = 0 unless defined $tofile;

  if(not $verbose) {
    if($tofile) {
      return qw(-v 2 -print_errors);
    } else {
      return qw(-v 0 -noprint_errors);
    }
  } else {
    return qw(-v 2 -print_errors);
  }
}

###############################################################################

sub dir_args {
  my $resultdir = shift;
  return ('-build_dir', $resultdir, '-dest_dir', $resultdir, '-nocleanup');
}

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