cmd/lgrpinfo/lgrpinfo.pl

#! /usr/perl5/bin/perl
#
# CDDL HEADER START
#
# The contents of this file are subject to the terms of the
# Common Development and Distribution License (the "License").
# You may not use this file except in compliance with the License.
#
# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
# or http://www.opensolaris.org/os/licensing.
# See the License for the specific language governing permissions
# and limitations under the License.
#
# When distributing Covered Code, include this CDDL HEADER in each
# file and include the License file at usr/src/OPENSOLARIS.LICENSE.
# If applicable, add the following below this CDDL HEADER, with the
# fields enclosed by brackets "[]" replaced with your own identifying
# information: Portions Copyright [yyyy] [name of copyright owner]
#
# CDDL HEADER END
#

#
# Copyright 2008 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#

#
# lgrpinfo: display information about locality groups.
#

require 5.8.4;
use warnings;
use strict;
use Getopt::Long qw(:config no_ignore_case bundling auto_version);
use File::Basename;
# Sun::Solaris::Kstat is used to extract per-lgroup load average.
use Sun::Solaris::Kstat;
use POSIX qw(locale_h);
use Sun::Solaris::Utils qw(textdomain gettext);
use Sun::Solaris::Lgrp ':CONSTANTS';

use constant KB => 1024;

#
# Amount of load contributed by a single thread. The value is exported by the
# kernel in the 'loadscale' variable of lgroup kstat, but in case it is missing
# we use the current default value as the best guess.
#
use constant LGRP_LOADAVG_THREAD_MAX => 65516;

# Get script name
our $cmdname = basename($0, ".pl");

# Get liblgrp version
my $version = Sun::Solaris::Lgrp::lgrp_version();

our $VERSION = "%I% (liblgrp version $version)";

# The $loads hash keeps per-lgroup load average.
our $loads = {};

########################################
# Main body
##

# Set message locale
setlocale(LC_ALL, "");
textdomain(TEXT_DOMAIN);

# Parse command-line options
our($opt_a, $opt_l, $opt_m, $opt_c, $opt_C, $opt_e, $opt_t, $opt_h, $opt_u,
    $opt_r, $opt_L, $opt_P, $opt_I, $opt_T, $opt_G);

GetOptions("a"   => \$opt_a,
       "c"   => \$opt_c,
       "C"   => \$opt_C,
       "e"   => \$opt_e,
       "G"   => \$opt_G,
       "h|?" => \$opt_h,
       "l"   => \$opt_l,
       "L"   => \$opt_L,
       "I"   => \$opt_I,
       "m"   => \$opt_m,
       "r"   => \$opt_r,
       "t"   => \$opt_t,
       "T"   => \$opt_T,
       "u=s" => \$opt_u,
       "P"   => \$opt_P) || usage(3);

usage(0) if $opt_h;

# Check for conflicting options
my $nfilters = 0;
$nfilters++ if $opt_C;
$nfilters++ if $opt_P;
$nfilters++ if $opt_T;

if ($nfilters > 1) {
    printf STDERR
      gettext("%s: Options -C, -T and -P can not be used together\n"),
        $cmdname;
    usage(3);
}

if ($opt_T && ($opt_I || $opt_t)) {
    printf STDERR
      gettext("%s: Option -T can not be used with -I, -t\n"),
        $cmdname;
    usage(3);
}

if ($opt_T && scalar @ARGV) {
    printf STDERR
      gettext("%s: Warning: with '-T' all lgroups on the command line "),
        $cmdname;
    printf STDERR gettext("are ignored\n\n");
}

if ($opt_L && $opt_I) {
    printf STDERR gettext("%s: Option -I can not be used with -L\n"),
      $cmdname;
    usage(3);
}

# Figure out what to do based on options
my $do_default = 1 unless
  $opt_a || $opt_l || $opt_m || $opt_c || $opt_e || $opt_t || $opt_r;


my $l =  Sun::Solaris::Lgrp->new($opt_G ? LGRP_VIEW_OS : LGRP_VIEW_CALLER) or
    die(gettext("$cmdname: can not get lgroup information from the system\n"));


# Get list of all lgroups, the root and the list of intermediates
my @lgrps = nsort($l->lgrps);
my $root = $l->root;
my @intermediates = grep { $_ != $root && !$l->isleaf($_) } @lgrps;
my $is_uma = (scalar @lgrps == 1);

# Print everything if -a is specified or it is default without -T
my $do_all    = 1 if $opt_a  || ($do_default && !($opt_T || $opt_L));

# Print individual information if do_all or requested specific print
my $do_lat    = 1 if $do_all || $opt_l;
my $do_memory = 1 if $do_all || $opt_m;
my $do_cpu    = 1 if $do_all || $opt_c;
my $do_topo   = 1 if $do_all || $opt_t;
my $do_rsrc   = 1 if $do_all || $opt_r;
my $do_load   = 1 if $do_all || $opt_e;
my $do_table  = 1 if $opt_a  || $opt_L;
my $do_something = ($do_lat || $do_memory || $do_cpu || $do_topo ||
            $do_rsrc || $do_load);

# Does the liblgrp(3LIB) has enough capabilities to support resource view?
if ($do_rsrc && LGRP_VER_CURRENT == 1) {
    if ($opt_r) {
        printf STDERR
          gettext("%s: sorry, your system does not support"),
            $cmdname;
        printf STDERR " lgrp_resources(3LGRP)\n";
    }
    $do_rsrc = 0;
}

# Get list of lgrps from arguments, expanding symbolic names like
# "root" and "leaves"
# Use all lgroups if none are specified on the command line
my @lgrp_list = (scalar (@ARGV) && !$opt_T) ? lgrp_expand($l, @ARGV) : @lgrps;

# Apply 'Parent' or 'Children' operations if requested
@lgrp_list = map { $l->parents($_)  } @lgrp_list if $opt_P;
@lgrp_list = map { $l->children($_) } @lgrp_list if $opt_C;

# Drop repeating elements and sort lgroups numerically.
@lgrp_list = uniqsort(@lgrp_list);

# If both -L and -c are specified, just print list of CPUs.
if ($opt_c && $opt_I) {
    my @cpus = uniqsort(map { $l->cpus($_, LGRP_CONTENT_HIERARCHY) }
                @lgrp_list);
    print "@cpus\n";
    exit(0);
}

my $unit_str = "K";
my $units = KB;

# Convert units to canonical numeric and string formats.
if ($opt_u) {
    if ($opt_u =~ /^b$/i) {
        $units = 1;
        $unit_str = "B";
    } elsif ($opt_u =~ /^k$/i) {
        $units = KB;
        $unit_str = "K";
    } elsif ($opt_u =~ /^m$/i) {
        $units = KB * KB;
        $unit_str = "M";
    } elsif ($opt_u =~ /^g$/i) {
        $units = KB * KB * KB;
        $unit_str = "G";
    } elsif ($opt_u =~ /^t$/i) {
        $units = KB * KB * KB * KB;
        $unit_str = "T";
    } elsif ($opt_u =~ /^p$/i) {
        $units = KB * KB * KB * KB * KB;
        $unit_str = "P";
    } elsif ($opt_u =~ /^e$/i) {
        $units = KB * KB * KB * KB * KB * KB;
        $unit_str = "E";
    } elsif (! ($opt_u =~ /^m$/i)) {
        printf STDERR
          gettext("%s: invalid unit '$opt_u', should be [b|k|m|g|t|p|e]"),
            $cmdname;
        printf STDERR gettext(", using the default.\n\n");
        $opt_u = 0;
    }
}

# Collect load average data if requested.
$loads = get_lav() if $do_load;

# Get latency values for each lgroup.
my %self_latencies;
map { $self_latencies{$_} = $l->latency($_, $_) } @lgrps;

# If -T is specified, just print topology and return.
if ($opt_T) {
    lgrp_prettyprint($l);
    print_latency_table(\@lgrps, \@lgrps) if $do_table;
    exit(0);
}

if (!scalar @lgrp_list) {
    printf STDERR gettext("%s: No matching lgroups found!\n"), $cmdname;
    exit(2);
}

# Just print list of lgrps if doing just filtering
(print "@lgrp_list\n"), exit 0 if $opt_I;

if ($do_something) {
    # Walk through each requested lgrp and print whatever is requested.
    foreach my $lgrp (@lgrp_list) {
        my $is_leaf = $l->isleaf($lgrp);
        my ($children, $parents, $cpus, $memstr, $rsrc);

        my $prefix = ($lgrp == $root) ?
          "root": $is_leaf ? gettext("leaf") : gettext("intermediate");
        printf gettext("lgroup %d (%s):"), $lgrp, $prefix;

        if ($do_topo) {
            # Get children of this lgrp.
            my @children = $l->children($lgrp);
            $children = $is_leaf ?
              gettext("Children: none") :
                gettext("Children: ") . lgrp_collapse(@children);
            # Are there any parents for this lgrp?
            my @parents = $l->parents($lgrp);
            $parents = @parents ?
              gettext(", Parent: ") . "@parents" :
                "";
        }

        if ($do_cpu) {
            $cpus = lgrp_showcpus($lgrp, LGRP_CONTENT_HIERARCHY);
        }
        if ($do_memory) {
            $memstr = lgrp_showmemory($lgrp, LGRP_CONTENT_HIERARCHY);
        }
        if ($do_rsrc) {
            $rsrc = lgrp_showresources($lgrp);
        }

        # Print all the information about lgrp.
        print "\n\t$children$parents"   if $do_topo;
        print "\n\t$cpus"       if $do_cpu && $cpus;
        print "\n\t$memstr"     if $do_memory && $memstr;
        print "\n\t$rsrc"       if $do_rsrc;
        print "\n\t$loads->{$lgrp}" if defined ($loads->{$lgrp});
        if ($do_lat && defined($self_latencies{$lgrp})) {
            printf gettext("\n\tLatency: %d"), $self_latencies{$lgrp};
        }
        print "\n";
    }
}

print_latency_table(\@lgrps, \@lgrp_list) if $do_table;

exit 0;

#
# usage(exit_status)
# print usage message and exit with the specified exit status.
#
sub usage
{
    printf STDERR gettext("Usage:\t%s"), $cmdname;
    print STDERR " [-aceGlLmrt] [-u unit] [-C|-P] [lgrp] ...\n";
    print STDERR "      \t$cmdname -I [-c] [-G] [-C|-P] [lgrp] ...\n";
    print STDERR "      \t$cmdname -T [-aceGlLmr] [-u unit]\n";
    print STDERR "      \t$cmdname -h\n\n";

    printf STDERR
      gettext("   Display information about locality groups\n\n" .
          "\t-a: Equivalent to \"%s\" without -T and to \"%s\" with -T\n"),
            "-celLmrt", "-celLmr";

    print STDERR
      gettext("\t-c: Print CPU information\n"),
      gettext("\t-C: Children of the specified lgroups\n"),
      gettext("\t-e: Print lgroup load average\n"),
      gettext("\t-h: Print this message and exit\n"),
      gettext("\t-I: Print lgroup or CPU IDs only\n"),
      gettext("\t-l: Print information about lgroup latencies\n"),
      gettext("\t-G: Print OS view of lgroup hierarchy\n"),
      gettext("\t-L: Print lgroup latency table\n"),
      gettext("\t-m: Print memory information\n"),
      gettext("\t-P: Parent(s) of the specified lgroups\n"),
      gettext("\t-r: Print lgroup resources\n"),
      gettext("\t-t: Print information about lgroup topology\n"),
      gettext("\t-T: Print the hierarchy tree\n"),
      gettext("\t-u unit: Specify memory unit (b,k,m,g,t,p,e)\n\n\n");

    print STDERR
      gettext("    The lgrp may be specified as an lgroup ID,"),
      gettext(" \"root\", \"all\",\n"),
      gettext("    \"intermediate\" or \"leaves\".\n\n");

    printf STDERR
      gettext("    The default set of options is \"%s\"\n\n"),
        "-celmrt all";

    print STDERR
      gettext("    Without any options print topology, CPU and memory " .
          "information about each\n" .
          "    lgroup. If any lgroup IDs are specified on the " .
          "command line only print\n" .
          "    information about the specified lgroup.\n\n");

    exit(shift);
}

# Return the input list with duplicates removed.
sub uniq
{
    my %seen;
    return (grep { ++$seen{$_} == 1 } @_);
}

#
# Sort the list numerically
# Should be called in list context
#
sub nsort
{
    return (sort { $a <=> $b } @_);
}

#
# Sort list numerically and remove duplicates
# Should be called in list context
#
sub uniqsort
{
    return (sort { $a <=> $b } uniq(@_));
}

# Round values
sub round
{
    my $val = shift;

    return (int($val + 0.5));
}

#
# Expand list of lgrps.
#   Translate 'root' to the root lgrp id
#   Translate 'all' to the list of all lgrps
#   Translate 'leaves' to the list of all lgrps'
#   Translate 'intermediate' to the list of intermediates.
#
sub lgrp_expand
{
    my $lobj = shift;
    my %seen;
    my @result;

    # create a hash element for every element in @lgrps
    map { $seen{$_}++ } @lgrps;

    foreach my $lgrp (@_) {
        push(@result, $lobj->root),   next if $lgrp =~ m/^root$/i;
        push(@result, @lgrps),        next if $lgrp =~ m/^all$/i;
        push(@result, $lobj->leaves), next if $lgrp =~ m/^leaves$/i;
        push(@result, @intermediates),
          next if $lgrp =~ m/^intermediate$/i;
        push(@result, $lgrp),
          next if $lgrp =~ m/^\d+$/ && $seen{$lgrp};
        printf STDERR gettext("%s: skipping invalid lgrp $lgrp\n"),
          $cmdname;
    }

    return @result;
}

#
# lgrp_tree(class, node)
#
# Build the tree of the lgroup hierarchy starting with the specified node or
# root if no initial node is specified. Calls itself recursively specifying each
# of the children as a starting node. Builds a reference to the list with the
# node in the end and each element being a subtree.
#
sub lgrp_tree
{
    my $c = shift;
    my $lgrp = shift || $c->root;

    # Call itself for each of the children and combine results in a list.
    [ (map { lgrp_tree($c, $_) } $c->children($lgrp)), $lgrp ];
}

#
# lgrp_pp(tree, prefix, childprefix, npeers)
#
# pretty-print the hierarchy tree.
# Input Arguments:
#   Reference to the tree
#   Prefix for me to use
#   Prefix for my children to use
#   Number of peers left
#
sub lgrp_pp
{
    my $tree = shift;
    my $myprefix = shift;
    my $childprefix = shift;
    my $npeers = shift;
    my $el = pop @$tree;
    my $nchildren = scalar @$tree;
    my $printprefix = "$childprefix";
    my $printpostfix = $npeers ? "|   " : "    ";

    return unless defined ($el);

    my $bar = $npeers ? "|" : "`";
    print $childprefix ? $childprefix : "";
    print $myprefix ? "$bar" . "-- " : "";
    lgrp_print($el, "$printprefix$printpostfix");

    my $new_prefix = $npeers ? $myprefix : "    ";

    # Pretty-print the subtree with a new offset.
    map {
        lgrp_pp($_, "|   ", "$childprefix$new_prefix", --$nchildren)
    } @$tree;
}

# Pretty print the whole tree
sub lgrp_prettyprint
{
    my $c = shift;
    my $tree = lgrp_tree $c;
    lgrp_pp($tree, '', '', scalar $tree - 1);
}

sub lgrp_print
{
    my $lgrp = shift;
    my $prefix = shift;
    my ($cpus, $memstr, $rsrc);
    my $is_interm = ($lgrp != $root && !$l->isleaf($lgrp));
    my $not_root = $is_uma || $lgrp != $root;

    print "$lgrp";

    if ($do_cpu && $not_root) {
        $cpus   = lgrp_showcpus($lgrp, LGRP_CONTENT_HIERARCHY);
    }
    if ($do_memory && $not_root) {
        $memstr = lgrp_showmemory($lgrp, LGRP_CONTENT_HIERARCHY);
    }
    if ($do_rsrc && ($is_uma || $is_interm)) {
        $rsrc   = lgrp_showresources($lgrp) if $do_rsrc;
    }

    # Print all the information about lgrp.

    print "\n$prefix$cpus"      if $cpus;
    print "\n$prefix$memstr"    if $memstr;
    print "\n$prefix$rsrc"      if $rsrc;
    print "\n$prefix$loads->{$lgrp}"    if defined ($loads->{$lgrp});

    # Print latency information if requested.
    if ($do_lat && $lgrp != $root && defined($self_latencies{$lgrp})) {
        print "\n${prefix}";
        printf gettext("Latency: %d"), $self_latencies{$lgrp};
    }
    print "\n";
}

# What CPUs are in this lgrp?
sub lgrp_showcpus
{
    my $lgrp = shift;
    my $hier = shift;

    my @cpus = $l->cpus($lgrp, $hier);
    my $ncpus = @cpus;
    return 0 unless $ncpus;
    # Sort CPU list if there is something to sort.
    @cpus = nsort(@cpus) if ($ncpus > 1);
    my $cpu_string = lgrp_collapse(@cpus);
    return (($ncpus == 1) ?
        gettext("CPU: ") . $cpu_string:
        gettext("CPUs: ") . $cpu_string);
}

# How much memory does this lgrp contain?
sub lgrp_showmemory
{
    my $lgrp = shift;
    my $hier = shift;

    my $memory = $l->mem_size($lgrp, LGRP_MEM_SZ_INSTALLED, $hier);
    return (0) unless $memory;
    my $freemem = $l->mem_size($lgrp, LGRP_MEM_SZ_FREE, $hier) || 0;

    my $memory_r = memory_to_string($memory);
    my $freemem_r = memory_to_string($freemem);
    my $usedmem = memory_to_string($memory - $freemem);

    my $memstr = sprintf(gettext("Memory: installed %s"),
                 $memory_r);
    $memstr = $memstr . sprintf(gettext(", allocated %s"),
                    $usedmem);
    $memstr = $memstr . sprintf(gettext(", free %s"),
                    $freemem_r);
    return ($memstr);
}

# Get string containing lgroup resources
sub lgrp_showresources
{
    my $lgrp = shift;
    my $rsrc_prefix = gettext("Lgroup resources:");
    # What resources does this lgroup contain?
    my @resources_cpu = nsort($l->resources($lgrp, LGRP_RSRC_CPU));
    my @resources_mem = nsort($l->resources($lgrp, LGRP_RSRC_MEM));
    my $rsrc = @resources_cpu || @resources_mem ? "" : gettext("none");
    $rsrc = $rsrc_prefix . $rsrc;
    my $rsrc_cpu = lgrp_collapse(@resources_cpu);
    my $rsrc_mem = lgrp_collapse(@resources_mem);
    my $lcpu = gettext("CPU");
    my $lmemory = gettext("memory");
    $rsrc = "$rsrc $rsrc_cpu ($lcpu);" if scalar @resources_cpu;
    $rsrc = "$rsrc $rsrc_mem ($lmemory)" if scalar @resources_mem;
    return ($rsrc);
}

#
# Consolidate consequtive ids as start-end
# Input: list of ids
# Output: string with space-sepated cpu values with ranges
#   collapsed as x-y
#
sub lgrp_collapse
{
    return ('') unless @_;
    my @args = uniqsort(@_);
    my $start = shift(@args);
    my $result = '';
    my $end = $start;   # Initial range consists of the first element
    foreach my $el (@args) {
        if ($el == ($end + 1)) {
            #
            # Got consecutive ID, so extend end of range without
            # printing anything since the range may extend further
            #
            $end = $el;
        } else {
            #
            # Next ID is not consecutive, so print IDs gotten so
            # far.
            #
            if ($end > $start + 1) {    # range
                $result = "$result $start-$end";
            } elsif ($end > $start) {   # different values
                $result = "$result $start $end";
            } else {    # same value
                $result = "$result $start";
            }

            # Try finding consecutive range starting from this ID
            $start = $end = $el;
        }
    }

    # Print last ID(s)
    if ($end > $start + 1) {
        $result = "$result $start-$end";
    } elsif ($end > $start) {
        $result = "$result $start $end";
    } else {
        $result = "$result $start";
    }
    # Remove any spaces in the beginning
    $result =~ s/^\s+//;
    return ($result);
}

# Print latency information if requested and the system has several lgroups.
sub print_latency_table
{
    my ($lgrps1, $lgrps2) = @_;

    return unless scalar @lgrps;

    # Find maximum lgroup
    my $max = $root;
    map { $max = $_ if $max < $_ } @$lgrps1;

    # Field width for lgroup - the width of the largest lgroup and 1 space
    my $lgwidth = length($max) + 1;
    # Field width for latency. Get the maximum latency and add 1 space.
    my $width = length($l->latency($root, $root)) + 1;
    # Make sure that width is enough to print lgroup itself.
    $width = $lgwidth if $width < $lgwidth;

    # Print table header
    print gettext("\nLgroup latencies:\n");
    # Print horizontal line
    print "\n", "-" x ($lgwidth + 1);
    map { print '-' x $width } @$lgrps1;
    print "\n", " " x $lgwidth, "|";
    map { printf("%${width}d", $_) } @$lgrps1;
    print "\n", "-" x ($lgwidth + 1);
    map { print '-' x $width } @$lgrps1;
    print "\n";

    # Print the latency table
    foreach my $l1 (@$lgrps2) {
        printf "%-${lgwidth}d|", $l1;
        foreach my $l2 (@lgrps) {
            my $latency = $l->latency($l1, $l2);
            if (!defined ($latency)) {
                printf "%${width}s", "-";
            } else {
                printf "%${width}d", $latency;
            }
        }
        print "\n";
    }

    # Print table footer
    print "-" x ($lgwidth + 1);
    map { print '-' x $width } @lgrps;
    print "\n";
}

#
# Convert a number to a string representation
# The number is scaled down until it is small enough to be in a good
# human readable format i.e. in the range 0 thru 1023.
# If it's smaller than 10 there's room enough to provide one decimal place.
#
sub number_to_scaled_string
{
    my $number = shift;

    my $scale = KB;
    my @measurement = ('K', 'M', 'G', 'T', 'P', 'E');   # Measurement
    my $uom = shift(@measurement);
    my $result;

    my $save = $number;

    # Get size in K.
    $number /= KB;

    while (($number >= $scale) && $uom ne 'E') {
        $uom = shift(@measurement);
        $save = $number;
        $number /= $scale;
    }

    # check if we should output a decimal place after the point
    if ($save && (($save / $scale) < 10)) {
        $result = sprintf("%2.1f", $save / $scale);
    } else {
        $result = round($number);
    }
    return ("$result$uom");
}

#
# Convert memory size to the string representation
#
sub memory_to_string
{
    my $number = shift;

    # Zero memory - just print 0
    return ("0$unit_str") unless $number;

    #
    # Return memory size scaled to human-readable form unless -u is
    # specified.
    #
    return (number_to_scaled_string($number)) unless $opt_u;

    my $scaled = $number / $units;
    my $result;

    if ($scaled < 0.1) {
        $result = sprintf("%2.1g", $scaled);
    } elsif ($scaled < 10) {
        $result = sprintf("%2.1f", $scaled);
    } else {
        $result = int($scaled + 0.5);
    }
    return ("$result$unit_str");
}

#
# Read load averages from lgrp kstats Return hash reference indexed by lgroup ID
# for each lgroup which has load information.
#
sub get_lav
{
    my $load = {};

    my $ks = Sun::Solaris::Kstat->new(strip_strings => 1) or
      warn(gettext("$cmdname: kstat_open() failed: %!\n")),
        return $load;

    my $lgrp_kstats = $ks->{lgrp} or
      warn(gettext("$cmdname: can not read lgrp kstat\n)")),
        return $load;

    # Collect load for each lgroup
    foreach my $i (keys %$lgrp_kstats) {
        next unless $lgrp_kstats->{$i}->{"lgrp$i"};
        my $lav = $lgrp_kstats->{$i}->{"lgrp$i"}->{"load average"};
        # Skip this lgroup if can't find its load average
        next unless defined $lav;
        my $scale = $lgrp_kstats->{$i}->{"lgrp$i"}->{"loadscale"} ||
            LGRP_LOADAVG_THREAD_MAX;
        $load->{$i} = sprintf (gettext("Load: %4.3g"), $lav / $scale);
    }
    return $load;
}