=head1 NAME

CFX5::Arch - architecture handling for CFX-5 scripts

=head1 SYNOPSIS

  use CFX5::Arch qw(choose_arch);

=head1 DESCRIPTION

The CFX5::Arch module provides code to handle CFX-5
architecture and OS strings such as

  sgi_r12k_irix6.5
  irix

These are for use in auto-selecting architectures for components which
can be optimised for more than one platform.

The library consists of two parts: an object class for objects
representing these architectures, and a set of routines which use this
class.

=head2 NAMING CONVENTIONS

The following conventions are used.  Each architecture string is
broken down into the following three parts:

=over

=item vendor

=item cpu

=item os

=back

in the obvious way, by breaking them apart at the underscores.  The
vendor information is just a string.  The OS information is broken
down into an OS name and version, by simply breaking apart the name
and number.

The CPU information is broken down into a CPU name and CPU version,
but in a rather more complex way than the others, to allow us to do
meaningful comparisons of different CPU types.  Each basic type is
given a name, and then a version (if one can be determined) is
extracted from the name.  For example, an SGI C<r10k> chip would come
out as cpuname "rk", cpuver "10".

In addition, processors such as the Intel-derived AMD vs Intel are
split into sub-families by appending a slash and the sub-family name,
for example the AMD Athlon has cpuname "ia32/amd", whereas a basic
Pentium has cpuname "ia32", and a Pentium III has "ia32/intel".
Different families are not seen as compatible, but any family is
compatible with the basic type.  Any level of sub-families is
permitted, for example "ia32/intel/sse", with the same semantics as
above.

Note that these breakdowns are for internal processing only, and
although they are all derived from the original architecture string,
they are not reflected in it if the string is reformed.

=cut

package CFX5::Arch;
use strict;

use CFX5::Output qw(:all);

=head1 CFX5::Arch

This is the object which represents the architecture.

=head2 INITIALISATION

=head3 new

  my $arch=CFX5::Arch->new('sgi_r10k_irix6.5');

The C<new> routine should be passed the name of the architecture which
the object is to represent.

=cut

sub new {
  my $this=shift;
  my $class=ref($this) || $this;
  my $self={};
  bless $self, $class;
  $self->init($this, @_);
  $self;
}

sub init {
  my $self=shift;
  my $this=shift;
  if (@_) {
    # use the arguments
    $self->set(shift);
  } elsif (ref $this and $this->isa(__PACKAGE__)) {
    $self->set($this->{orig});
  } else {
    internal_error("Missing initialisation to ", __PACKAGE__, " object.");
  }
}

=head3 isok

  unless (CFX5::Arch->isok($arch)) {
    # die
  }

Returns TRUE if the specified architecture string is parsable (at a
fairly non-strict level at the moment), or FALSE if it is just
rubbish.

I<New code should use is_valid_arch instead>; this call was added
accidentally (!), and will be removed at some point.

=cut

sub isok {
  my $class=shift;
  return $class->is_valid_arch(@_);
}

sub set {
  my $self=shift;
  my $to=shift;
  $self->{orig}=$to;
  if ($to =~ m!^([^_]*)_([^_]*)_([^_]*)(_.*)?$!) {
    # eg sgi_r5k_irix6.5
    my ($vendor,$cpu,$os)=($1,$2,$3);
    $self->{vendor}=$vendor;
    $self->{cpu}=$cpu;
    $self->{os}=$os;

    # OK, what if it's IA64?
    if ($self->{cpu} eq 'ia64') {
      $self->osname();
      $self->{osname} .= '-ia64';
    }

    # OK, what if it's X86_64?
    if ($self->{cpu} =~ m!^opteron!) {
      $self->osname();
      if( $self->{osname} eq "winnt" ){
        require Config;
        $self->{osname} .= '-amd64' if $Config::Config{archname}=~m/x64/;
      } else {
        $self->{osname} .= '-amd64';
      }
    }
    if ($self->{cpu} =~ m!^xeon64!) {
      $self->osname();
      if( $self->{osname} eq "winnt" ){
	require Config;
	$self->{osname} .= '-amd64' if $Config::Config{archname}=~m/x64/;
      } else {
        $self->{osname} .= '-amd64';
      }
    }

  } elsif ($to =~ m!^([a-z]+)(-ia64|-amd64)?$!) {
    # eg irix
    $self->{os}=$to;
    delete $self->{vendor};
    if ($2) {
      ($self->{cpu} = $2) =~ s!^-*!!;
    } else {
      delete $self->{cpu};
    }
  } else {
    _abort(qq(Architecture string "$to" cannot be parsed));
  }
}

=head2 CLASS METHODS

=head3 is_valid_arch

  if (CFX5::Arch->is_valid_arch($arch)) {
    # ...
  }

This is useful, as we now give an error if an invalid architecture is
passed in.

=cut

sub is_valid_arch {
  my $self=shift;
  my $to=shift;
  if ($to =~ m!^([^_]*)_([^_]*)_([^_]*)(_.*)?$!) {
    return 'full';
  } elsif ($to =~ m!^[a-z]+(?:-ia64|-amd64)?$!) {
    return 'os';
  } else {
    return '';
  }
}

=head2 INTERROGATION

=head3 vendor

Returns the vendor information for this arch, if there is any.

=cut

sub vendor {
  my $self=shift;
  $self->{vendor};
}

=head3 cpu

Returns the cpu information for this arch, if there is any.

=cut

sub cpu {
  my $self=shift;
  $self->{cpu};
}

=head3 cpuname

Tries to extract a name from the CPU in the current architecture, and
return that.

=cut

sub cpuname {
  my $self=shift;
  unless (exists $self->{cpuname}) {
    # even if we can't work it out, we don't want to bother trying
    # again.
    $self->{cpuname}=undef;
    $self->{cpuver}=undef;

    my $cpu=$self->{cpu};
    if (!defined $cpu) {
      # no idea, mate
      1;
    } elsif ($cpu =~ m!^r(\d+)k$!) {
      # SGI
      $self->{cpuname}='rk';
      $self->{cpuver}=$1;
    } elsif ($cpu eq 'mips') {
      # un-recognised SGI CPU, treat as < all others.
      $self->{cpuname}='rk';
      $self->{cpuver}=0;
    } elsif ($cpu eq 'alpha') {
      # DEC
      $self->{cpuname}='alpha';
      $self->{cpuver}=0;
    } elsif ($cpu =~ m!^(u?)sparc!) {
      $self->{cpuname}='sparc';
      $self->{cpuver}=($1 eq 'u' ? 1 : 0);
    } elsif ($cpu =~ m!^pwr(.*)$!) {
      # AIX POWER*
      $self->{cpuname}='power';
      $self->{cpuver}=$1 || 1;
    } elsif ($cpu eq 'ppc') {
      # AIX PPC, assume less than all the other pwr* values
      $self->{cpuname}='power';
      $self->{cpuver}=0;
    } elsif ($cpu =~ m!^pa(\d)\.x$!) {
      # HP PA, but we don't recognise the subversion; assume it's just
      # the base version with this major number.  TODO: This makes it
      # equivalent to the base version of the CPU.  Is this right?  So
      # pa2.0 and pa2.x are considered equivalent ... I think this is
      # probably right.
      $self->{cpuname}='pa';
      $self->{cpuver}=$1;
    } elsif ($cpu eq 'pa') {
      # HP PA, but we don't recognise it at all!
      $self->{cpuname}='pa';
      $self->{cpuver}=0;
    } elsif ($cpu eq 'ia64') {
      # base-level IA64
      $self->{cpuname}='ia64';
      $self->{cpuver}=0;
    } elsif ($cpu eq 'amd64') {
      # base level x86_64 CPUs 
      $self->{cpuname}='x86_64';
      $self->{cpuver}=0;
    } elsif ($cpu =~ m/^opteron/) {
      # specific check for Opteron in CPU string
      $self->{cpuname}='x86_64';
      $self->{cpuver}=0;
      if ($cpu =~ m!\.sse([0-9]*)!) {
        # got SSE, that's a sub-sub-family!
        $self->{cpuname} .= "/sse$1";
      }
    } elsif ($cpu =~ m/^xeon64/) {
      # specific check for Opteron in CPU string
      $self->{cpuname}='x86_64';
      $self->{cpuver}=0;
      if ($cpu =~ m!\.sse([0-9]*)!) {
        # got SSE, that's a sub-sub-family!
        $self->{cpuname} .= "/sse$1";
      }
    } elsif ($cpu =~ m/^(i[3456]86|ia32)$/) {
      # base-level Intel or compatible
      $self->{cpuname}='ia32';
      $self->{cpuver}=0;
    } elsif (lc($cpu) eq 'k6') {
      # AMD K6 => Pentium 2
      $self->{cpuname}='ia32';
      $self->{cpuver}=2;
    } elsif ($cpu =~ m/^p(?:entium)?([0-9]+)/ or $cpu =~ m/^pentium$/) {
      # Intel pentium or above
      $self->{cpuver}=$1 || 1;
      if ($self->{cpuver} <= 2) {
        # Pentium II is considered in the bog-standard ia32 line (as
        # is AMD K6)
        $self->{cpuname}='ia32';
      } else {
        $self->{cpuname}='ia32/intel';
        if ($cpu =~ m!\.sse([0-9]*)!) {
          # got SSE, that's a sub-sub-family!
          $self->{cpuname} .= "/sse$1";
        }
      }
    } elsif ($cpu eq 'athlon') {
      # AMD athlon
      $self->{cpuname}='ia32/amd';
      $self->{cpuver}=7; # athlon => k7
    } elsif ($cpu =~ m!^([A-Za-z]+)([0-9]+)$!) {
      # easy!
      $self->{cpuname}=$1;
      $self->{cpuver}=$2;
    } elsif ($cpu =~ m!^([A-Za-z]+)([0-9]+\.[0-9]+)$!) {
      # also easy!
      $self->{cpuname}=$1;
      $self->{cpuver}=$2;
    } else {
      # nope, we've failed
      _trace "Unparsable CPU type $cpu";
    }
  }
  $self->{cpuname};
}

=head3 cpuver

Returns the version of the CPU, as a number, or undef.

=cut

sub cpuver {
  my $self=shift;
  unless (exists $self->{cpuver}) {
    # we do both at the same time
    $self->cpuname();
  }
  $self->{cpuver};
}

=head3 os

Returns the os information for this arch, if there is any.

=cut

sub os {
  my $self=shift;
  $self->{os};
}

=head3 osname

Returns just the name of this OS.  This is the name used in the
variable C<CFX5OS>.

=cut

sub osname {
  my $self=shift;
  unless (exists $self->{osname}) {
    $self->{osname}=$self->{os};
    # we create the OS name by stripping any trailing version info,
    # ie, anything following a digit.  But we need to preserve any -ia64
    # or -amd64 suffixes.
    if ($self->{osname} =~ s!(-ia64|-amd64)!!) {
      my $suff=$1;
      $self->{osname} =~ s!\d.*$!!;
      $self->{osname} .= $suff;
    } else {
      $self->{osname} =~ s!\d.*$!!;
    }
  }
  $self->{osname};
}

=head3 osver

Returns the version of this OS as a list of integers, one for each
part of the version number; for example, C<hpux10.20> becomes C<(10,
20)>.  If there is no number, eg because the object was initialised
from an OS name only, the return value is an empty list.

=cut

sub osver {
  my $self=shift;
  unless (exists $self->{osverl}) {
    my $ver=$self->{os};
    $ver =~ s!-(?:ia64|amd64)!!;
    $ver =~ s![^\d.]*!!g;
    my @list=split(/\./,$ver);
    $self->{osverl}=\@list;
  }
  @{$self->{osverl}};
}

=head3 pvm_arch

  $arch->pvm_arch();
  CFX5::Arch->pvm_arch('linux-amd64');

Returns the PVM_ARCH setting which most closely matches this object.
If the optional argument is passed, this can be used as a class method
to return the PVM_ARCH for any given CFX5OS value.

=cut

sub pvm_arch {
  my $self=shift;
  my $for_os=shift;

  my %arch=(
            winnt => 'WIN32',
	    'winnt-amd64' => 'WINX64',
            aix => 'RS6K64',
            osf => 'ALPHA',
            hpux => 'HPPA64',
            'hpux-ia64' => 'HPIA64',
            linux => 'LINUX',
            'linux-ia64' => 'LINUX64',
            'linux-amd64' => 'LINUXX86_64',
            irix => 'SGI64',
            solaris => 'SUN4SOL264',
           );
  if (not defined $for_os) {
    $for_os=$self->osname();
  }
  if (defined $for_os and defined $arch{$for_os}) {
    return $arch{$for_os};
  }
  return undef;
}

=head2 COMPARISONS

=head3 types_equal

Compares the operating system and/or vendor information about two
objects, to see if they may be compatible or not:

=over

=item 1. Operating System Name

If the OS name is different, they are not compatible.

=item 2. Vendor

If both architectures have vendor information, it is compared, and if
the vendor is different they are not compatible.

=item 3.

Otherwise, they are assumed to be compatible.

=back

=cut

sub types_equal {
  my $self=shift;
  my $with=shift;

  if ($self->osname() ne $with->osname()) {
    return undef;
  }
  my ($s,$w)=($self->vendor(),$with->vendor());
  if (defined $s and defined $w
      and $s ne $w) {
    return undef;
  }
  1;
}

=head3 compare_cpu

Compares the CPU versions of the two architectures, and returns -1 if
the first is older, 0 if they are the same, or 1 if the second is
older.  The default CPU (ie, the object was initialised from an OS
only) is considered older than anything else.  

If the CPUs are not compatible (ie, have a different C<cpuname>), the
return value is undef.  Note that no attempt is made to verify that
the rest of the architecture is compatible, so for example a
comparison between 'aix' and 'sgi_r5k_irix6.5' will claim that the R5K
is newer.

If the C<cpuname> contains a sub-family specification (ie,
"ia32/intel"), then two processors are compatible if either

=over

=item *

Only one C<cpuname> has a sub-family name, and one is generic.

=item *

The sub-family names are the same.

=back

A CPU with a sub-family name is always considered newer than a generic
one.

=cut

sub compare_cpu {
  my $self=shift;
  my $with=shift;
  my ($a,$b)=($self->cpu(),$with->cpu());

  if (!defined $a and !defined $b) {
    return '';
  }
  if (defined $a and !defined $b) { return 1; }
  if (defined $b and !defined $a) { return -1; }

  # we have them all; are they the same?
  if ($self->cpuname() ne $with->cpuname()) {
    my @sfams=split('/',$self->cpuname());
    my @wfams=split('/',$with->cpuname());

    while (@sfams and @wfams) {
      my $sf=shift @sfams;
      my $wf=shift @wfams;

      if ($sf ne $wf) {
        _trace("Incompatible (sub?)families $sf <=> $wf in", 
               $self->cpuname(), "and", $with->cpuname());
        return undef;
      }
    }
    if (@sfams) {
      # $self has a sub-family below $with, so that's newer
      return 1;
    } elsif (@wfams) {
      # $with has a sub-family below $self, so that's newer
      return -1;
    }
  }

  # yes.
  return $self->cpuver() <=> $with->cpuver();
}

=head3 compare_os

Compares the OS versions of the two architectures, and returns -1 if
the first is older, 0 if they are the same, or 1 if the second is
older.  The default OS (ie, the object was initialised from an OS
only) is considered older than anything else.  

The OS version strings are compared one item at a time, starting with
the major version, and the first difference ends the comparison.  If
one version list has more entries, but all common entries are equal,
then the longer list is considered later (newer) than the shorter.

If the OSes are not compatible (ie, have a different C<osname>), the
return value is undef.  Note that no attempt is made to verify that
the rest of the architecture is compatible.

=cut

sub compare_os {
  my $self=shift;
  my $with=shift;

  my ($a,$b)=($self->os(),$with->os());

  if (!defined $a and !defined $b) {
    return '';
  }
  if (defined $a and !defined $b) { return 1; }
  if (defined $b and !defined $a) { return -1; }

  # we have them all; are they the same?
  if ($self->osname() ne $with->osname()) {
    _trace "Incompatible OS types", $self->osname(), $with->osname();
    return undef;
  }

  # yes.
  my (@o1)=$self->osver();
  my (@o2)=$with->osver();
  while (@o1 and @o2) {
    my ($o1,$o2)=(shift @o1, shift @o2);
    if ($o1 <=> $o2) {
      return $o1 <=> $o2;
    }
  }
  if (@o1) { return 1; }
  if (@o2) { return -1; }
  return 0;
}

=head2 COMPATIBILITY TESTING

Now we begin to get to useful functions!  The functions in this
section are to do with whether code compiled I<for> (note: not I<on>)
on architecture will work on another.

=head3 will_run_on

  if ($thiscode->will_run_on($thishostarch)) {
    # ...
  }

Assuming that the current object represents the architecture for which
some code was compiled, returns TRUE if it can be expected to run on
the architecture represented by its argument, or FALSE if it cannot.
This roughly uses the algorithm set out in the document
L<IPRODUCT.MULTARCH.DESIGN.5.4>:

=over

=item 1.

Code optimsed for a given processor will run on that processor or
later.

=item 2.

Code built for a given major OS will not run on any other major OS
version.

=item 3.

Code build for a given minor OS version will run on that version or
later.

=back

but with minor tweaks where they are necessary to get the correct
answer.  For example, code for HP-UX 10.20 will run on HP-UX 11.

=cut

sub will_run_on {
  my $code=shift;
  my $host=shift;
  
  # are these even remotely similar?
  unless ($code->types_equal($host)) {
    return '';
  }

  # OK, try comparing the CPUs
  my $cpu=$code->compare_cpu($host);
  return '' unless defined $cpu;
  return '' if $cpu and $cpu > 0;

  # CPU looks OK, what about the OS version?  The OS name will have
  # been compared by types_equal.
  my @oscode=$code->osver();
  my @oshost=$host->osver();
  if (!@oscode) {
    # no OS version at all in the code, so anything will run on it.
    return 1;
  }
  if (!@oshost) {
    # no OS version in the host, but the code has one, so no can do.
    return '';
  }

  #
  # compare major versions -- in most cases, unless these are equal,
  # no chance.
  #
  if ($code->osname() eq 'hpux'
      and "$oscode[0].$oscode[1]" >= 10.20
      and "$oshost[0].$oshost[1]" >= 10.20
      and $oshost[0] <= 11) {
    # HP-UX 10.20 and above code can run on (any?) HP-UX 11 machine
    1;
  } elsif ($code->osname() eq 'winnt') {
    # code built *for* NT4 will run on NT5 (2000), but code build
    # *for* 2000 won't run on NT.  Code built *on* 2000 runs fine on
    # NT.  Confused yet?  Anyway, we just skip the major version check
    # on Windows, and let it be compared as a normal list.
    1;
  } elsif ($oscode[0] != $oshost[0]) {
    # OS major versions differ, give up.
    return '';
  } 

  #
  # we don't compare minor versions explicitly, we just say that older
  # code will run on newer hosts, but not vice versa.  Thus, if the
  # major versions are the same, we are effectively ignoring them.
  #
  my $os=$code->compare_os($host);
  return '' unless defined $os; # should never happen?
  return '' if $os > 0;

  # all looks groovy
  return 1;
}

=head3 run_code_for

  if ($thishost->run_code_for($codearch)) {
    # ...
  }

This is simply the opposite of C<will_run_on>; it returns TRUE if a
host with architecture represented by the current object will run code
compiled for the architecture given as an argument.

=cut

sub run_code_for {
  my $host=shift;
  my $code=shift;
  my $rv=$code->will_run_on($host);

  _debug($host->as_string(), ($rv ? "will" : "will not"), "run code for",
         $code->as_string());

  $rv;
}

=head3 filter_codes

  @candidate_code_arches = $hostarch->filter_codes(@all_code_arches);

Given a list of available code architectures, returns a list of those
which are good to try for this host.

=cut

sub filter_codes {
  my $host=shift;
  grep { $_->will_run_on($host) } @_;
}

=head3 compare_codes

  sort { $a->compare_codes($b) } @candidate_code_arches;

This is a sort-compatible comparison routine, which can be used to
rank codes in order of suitability.  It assumes that they have already
been filtered, eg with C<filter_codes>.

The algorithm is as stated in the document
L<IPRODUCT.MULTARCH.DESIGN.5.4>: if more than one executable seems to
match, but there is no obvious way of deciding which is better, the
one with the newest CPU version will be used.  Only if there are more
than one code for the same CPU version do we compare OS versions.

The return value is -1 if $a is not as good as $b, 0 if they are just
as good, or 1 if $a is better than $b, exactly like Perl's spaceship
and C<cmp> operators.

=cut '

sub compare_codes {
  my $a=shift;
  my $b=shift;
  
  my $cpu=$a->compare_cpu($b);
  return $cpu if $cpu;

  my $os=$a->compare_os($b);
  return $os if $os;

  0;
}

=head3 maybe_warn_code_for

  $hostarch->maybe_warn_code_for($codearch);

This call is provided to allow warnings about code which, while it
will run on a given processor, will be highly inefficient.  It simply
uses the C<_warn> call to give a warning if one is appropriate.

To start with, this will warn about running non-IA64 code (IA32 or
PA2) on an IA64 architecture where it will be emulated.

=cut

sub maybe_warn_code_for {
  my $host=shift;
  my $code=shift;
  my $desc=shift;

  return undef unless $host->run_code_for($code);

  # if we don't know what chipset we have, then we have to assume it's
  # OK 
  return 1 unless defined $host->cpu();

  # we don't yet have any sub-families of IA64 processors ...
  if ($host->cpu() eq 'ia64') {
    # ... and so, the only way this can be efficient is if we know
    # what processor the code is for, and it's ia64 too.
    unless (defined $code->cpu() and $code->cpu() eq 'ia64') {
      _warn((defined $desc ? $desc : ()),
            "Executables compiled for", $code->as_string(), 
            "will be run in software emulation mode on a",
            $host->as_string(), "host, leading to a significant decrease",
            "in performance.");
    }
  }
}

=head2 DISPLAY

=head3 as_string

  print $arch->as_string();

Returns a string representation of the architecture.

=cut

sub as_string {
  my $self=shift;

  # we might as well make some effort to normalise things
  if (defined $self->vendor() and defined $self->cpu()) {
    return $self->vendor() . '_' . $self->cpu() . '_' . $self->os();
  } else {
    return $self->osname();
  }
}

1;
