Initial commit of OpenSPARC T2 design and verification files.

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

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: Segment.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 -*-

package Midas::Segment;
use strict;
use warnings;
use Carp;
use Tie::IxHash;
use Midas::Command;
use Midas::Error;

use fields qw(type);

use constant
  {
    SEG_UNDEF  => 0,
    SEG_TEXT   => 1,
    SEG_DATA   => 2,
    SEG_BSS    => 3,
  };

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(SEG_UNDEF SEG_TEXT SEG_DATA SEG_BSS);



our %Segments =
  (
   SEG_TEXT()    => {
		     name        => 'text',
		     link_suffix => 't',
		     va_name     => 'text_va',
		     elfname     => '.text',
		     include_elf => [qw(.rodata)],
		     elfname_out => '.text .rodata',
		  },
   SEG_DATA()    => {
		     name        => 'data',
		     link_suffix => 'd',
		     va_name     => 'data_va',
		     elfname     => '.data',
		  },
   SEG_BSS()    =>  {
		     name        => 'bss',
		     link_suffix => 'b',
		     va_name     => 'bss_va',
		     elfname     => '.bss',
	          },
  );



our %RevNames = map { ( $Segments{$_}{name}, $_) } keys %Segments;
our %ElfNames = map
  { defined $Segments{$_}{elfname} ?
      ( $Segments{$_}{elfname}, $Segments{$_}{name} ) : () } keys %Segments;

foreach my $code (keys %Segments) {
  next unless exists $Segments{$code}{include_elf};
  foreach my $included (@{$Segments{$code}{include_elf}}) {
    $ElfNames{$included} = $Segments{$code}{name};
  }
}

our %LinkSuffixes = map
  { ( $Segments{$_}{link_suffix}, $Segments{$_}{name} ) } keys %Segments;

# rodata must appear before text or the linker will merge them
#our @Names = qw(rodata text data bss);
our @Names = qw(text data bss);

my @keys = keys %Segments;
if(@keys > @Names) {
  fatal "In Midas::Segment, @Names is incomplete.\n", M_CODE;
} elsif(@Names > @keys) {
  fatal "In Midas::Segment, @Names has extra entry\n", M_CODE;
}
foreach my $name (@Names) {
  fatal "Segment name '$name' is not set up correctly in Midas::Segment\n",
    M_CODE unless exists $RevNames{$name};
}

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

sub new {
  my $class = shift;
  my $type = shift;

  $type = $class->name2type($type) if $type =~ /[a-zA-Z]/;

  my $this;
  if(ref $class) {
    my $classtype = ref $class;
    $this = fields::new($classtype);
    $this->{type} = $class->type() if defined $class->type();
  } else {
    $this = fields::new($class);
    $this->{type} = $type if defined $type;
  }
  return $this;
}

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

sub type {
  my $this = shift;
  my $set  = shift;

  if(defined $set) {
    fatal Carp::longmess("No such segment type '$set'.\n"), M_CODE
      unless exists $Segments{$set}{name};
    $this->{type} = $set;
  }
  return $this->{type};
}

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

sub name {
  my $this = shift;
  my $set  = shift;

  if(defined $set) {
    $this->type($this->name2type($set));
  }
  return $this->type2name($this->{type});
}

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

sub is_segment_name {
  my $class = shift;
  my $name = shift;

  return 1 if exists $RevNames{$name};
  return 0;
}

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

sub name2type {
  my $class = shift;
  my $name  = shift;

  fatal Carp::longmess("No such segment name '$name'.\n"), M_CODE
    unless exists $RevNames{$name};

  return $RevNames{$name};
}

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

sub name2va_name {
  my $class = shift;
  my $name  = shift;

  fatal Carp::longmess("No such segment name '$name'.\n"), M_CODE
    unless exists $RevNames{$name};

  return $Segments{$RevNames{$name}}{va_name};
}

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

sub name2elf_name {
  my $class = shift;
  my $name  = shift;

  fatal Carp::longmess("No such segment name '$name'.\n"), M_CODE
    unless exists $RevNames{$name};

  return exists $Segments{$RevNames{$name}}{elfname_out} ?
    $Segments{$RevNames{$name}}{elfname_out} :
      $Segments{$RevNames{$name}}{elfname};
}

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

sub name2link_suffix {
  my $class = shift;
  my $name  = shift;

  fatal Carp::longmess("No such segment name '$name'.\n"), M_CODE
    unless exists $RevNames{$name};

  return $Segments{$RevNames{$name}}{link_suffix};
}

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

sub type2name {
  my $class = shift;
  my $type  = shift;

  fatal Carp::longmess("No such segment type '$type'.\n"), M_CODE
    unless exists $Segments{$type}{name};

  return $Segments{$type}{name};
}

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

sub all_names {
  my $class = shift;
  return @Names;
}

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

sub all_va_names {
  my $class = shift;
  return map { $Segments{$_}{va_name} } keys %Segments;
}

###############################################################################
###############################################################################
1;