summaryrefslogtreecommitdiff
path: root/usr/src/cmd/pginfo/pginfo.pl
diff options
context:
space:
mode:
Diffstat (limited to 'usr/src/cmd/pginfo/pginfo.pl')
-rw-r--r--usr/src/cmd/pginfo/pginfo.pl618
1 files changed, 618 insertions, 0 deletions
diff --git a/usr/src/cmd/pginfo/pginfo.pl b/usr/src/cmd/pginfo/pginfo.pl
new file mode 100644
index 0000000000..8a15b4adc9
--- /dev/null
+++ b/usr/src/cmd/pginfo/pginfo.pl
@@ -0,0 +1,618 @@
+#! /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 (c) 2010, Oracle and/or its affiliates. All rights reserved.
+#
+
+#
+# pginfo - tool for displaying Processor Group information
+#
+
+use warnings;
+use strict;
+use File::Basename;
+use Errno;
+use POSIX qw(locale_h);
+use Getopt::Long qw(:config no_ignore_case bundling auto_version);
+use List::Util qw(first max min);
+use Sun::Solaris::Utils qw(textdomain gettext);
+use Sun::Solaris::Pg;
+
+#
+# Constants
+#
+# It is possible that wnen trying to parse PG information, PG generation changes
+# which will cause PG new method to fail with errno set to EAGAIN In this case
+# we retry open up to RETRY_COUNT times pausing RETRY_DELAY seconds between each
+# retry.
+#
+# When printing PGs we print them as a little tree with each PG shifted by
+# LEVEL_OFFSET from each parent. For example:
+#
+# PG RELATIONSHIP CPUs
+# 0 System 0-7
+# 3 Socket 0 2 4 6
+# 2 Cache 0 2 4 6
+#
+
+use constant {
+ VERSION => 1.1,
+ LEVEL_OFFSET => 1,
+ RETRY_COUNT => 4,
+ RETRY_DELAY => 0.25,
+};
+
+#
+# Return codes
+#
+# 0 Successful completion.
+#
+# 1 An error occurred.
+#
+# 2 Invalid command-line options were specified.
+#
+use constant {
+ E_SUCCESS => 0,
+ E_ERROR => 1,
+ E_USAGE => 2,
+};
+
+
+# Set message locale
+setlocale(LC_ALL, "");
+textdomain(TEXT_DOMAIN);
+
+# Get script name for error messages
+our $cmdname = basename($0, ".pl");
+
+#
+# Process options
+#
+my $do_cpulist; # -C - Show CPU IDs
+my $do_cpus; # -c - Treat args as CPU IDs
+my $do_physical; # -p - Show physical relationships
+my $do_sharing_only; # -S - Only show sharing relationships
+my $do_tree; # -T - Show ASCII tree
+my $do_usage; # -h - Show usage
+my $do_version; # -V - Show version
+my $script_mode; # -I - Only show IDs
+my $verbose = 0; # -v - Verbose output
+my @sharing_filter; # -r string,...
+my @sharing_filter_neg; # -R string,...
+
+# Exit code
+my $rc = E_SUCCESS;
+
+# Parse options from the command line
+GetOptions("cpus|c" => \$do_cpus,
+ "idlist|I" => \$script_mode,
+ "cpulist|C" => \$do_cpulist,
+ "physical|p" => \$do_physical,
+ "help|h|?" => \$do_usage,
+ "sharing|s" => \$do_sharing_only,
+ "relationship|r=s" => \@sharing_filter,
+ "norelationship|R=s" => \@sharing_filter_neg,
+ "tree|topology|T" => \$do_tree,
+ "version|V" => \$do_version,
+ "verbose+" => \$verbose,
+ "v+" => \$verbose,
+) || usage(E_USAGE);
+
+# Print usage message when -h is given
+usage(E_SUCCESS) if $do_usage;
+
+if ($do_version) {
+ #
+ # Print version information and exit
+ #
+ printf gettext("%s version %s\n"), $cmdname, VERSION;
+ exit(E_SUCCESS);
+}
+
+#
+# Verify options compatibility
+#
+if ($script_mode && $do_cpulist) {
+ printf STDERR
+ gettext("%s: options -I and -C can not be used at the same time\n"),
+ $cmdname;
+ usage(E_USAGE);
+}
+
+if (($script_mode || $do_cpulist) &&
+ ($do_physical || $do_sharing_only ||
+ $do_tree)) {
+ printf STDERR
+ gettext("%s: options -C and -I can not be used with -p -s or -T\n"),
+ $cmdname;
+ usage(E_USAGE);
+}
+
+if ($do_physical && $do_sharing_only) {
+ printf STDERR
+ gettext("%s: option -p can not be used with -s\n"), $cmdname;
+ usage(E_USAGE);
+}
+
+if ($do_tree && $do_sharing_only) {
+ printf STDERR
+ gettext("%s: option -T can not be used with -s\n"),
+ $cmdname;
+ usage(E_USAGE);
+}
+
+if ($verbose && !($script_mode || $do_cpulist || $do_sharing_only)) {
+ $do_tree = 1;
+ $do_physical = 1;
+}
+
+#
+# Get PG information
+#
+my $p = Sun::Solaris::Pg->new(-tags => $do_physical,
+ -retry => RETRY_COUNT,
+ '-delay' => RETRY_DELAY);
+
+if (!$p) {
+ printf STDERR
+ gettext("%s: can not obtain Processor Group information: $!\n"),
+ $cmdname;
+ exit(E_ERROR);
+}
+
+#
+# Convert -[Rr] string1,string2,... into list (string1, string2, ...)
+#
+@sharing_filter = map { split /,/ } @sharing_filter;
+@sharing_filter_neg = map { split /,/ } @sharing_filter_neg;
+
+#
+# Get list of all PGs in the system
+#
+my @all_pgs = $p->all_depth_first();
+
+if (scalar(@all_pgs) == 0) {
+ printf STDERR
+ gettext("%s: this system does not have any Processor groups\n"),
+ $cmdname;
+ exit(E_ERROR);
+}
+
+#
+# @pgs is the list of PGs we are going to work with after all the option
+# processing
+#
+my @pgs = @all_pgs;
+
+#
+# get list of all CPUs in the system by looking at the root PG cpus
+#
+my @all_cpus = $p->cpus($p->root());
+
+#
+# If there are arguments in the command line, treat them as either PG IDs or as
+# CPUs that should be converted to PG IDs.
+# Arguments can be specified as x-y x,y,z and use special keyword 'all'
+#
+if (scalar @ARGV) {
+ #
+ # Convert 'all' in arguments to all CPUs or all PGs
+ #
+ my @args;
+ my @all = $do_cpus ? @all_cpus : @all_pgs;
+ @args = map { $_ eq 'all' ? @all : $_ } @ARGV;
+
+ # Expand any x-y,z ranges
+ @args = $p->expand(@args);
+
+ if ($do_cpus) {
+ # @bad_cpus is a list of invalid CPU IDs
+ my @bad_cpus = $p->set_subtract(\@all_cpus, \@args);
+ if (scalar @bad_cpus) {
+ printf STDERR
+ gettext("%s: Invalid processor IDs %s\n"),
+ $cmdname, $p->id_collapse(@bad_cpus);
+ $rc = E_ERROR;
+ }
+ #
+ # List of PGs is the list of any PGs that contain specified CPUs
+ #
+ @pgs = grep {
+ my @cpus = $p->cpus($_);
+ scalar($p->intersect(\@cpus, \@args));
+ } @all_pgs;
+ } else {
+ # @pgs is a list of valid CPUs in the arguments
+ @pgs = $p->intersect(\@all_pgs, \@args);
+ # @bad_pgs is a list of invalid PG IDs
+ my @bad_pgs = $p->set_subtract(\@all_pgs, \@args);
+ if (scalar @bad_pgs) {
+ printf STDERR
+ gettext("%s: Invalid PG IDs %s\n"),
+ $cmdname, $p->id_collapse(@bad_pgs);
+ $rc = E_ERROR;
+ }
+ }
+}
+
+#
+# Now we have list of PGs to work with. Now apply filtering. First list only
+# those matching -R
+#
+@pgs = grep { list_match($p->sh_name($_), @sharing_filter) } @pgs if
+ scalar @sharing_filter;
+
+# Remove any that doesn't match -r
+@pgs = grep { !list_match($p->sh_name($_), @sharing_filter_neg) } @pgs if
+ scalar @sharing_filter_neg;
+
+# Do we have any PGs left?
+if (scalar(@pgs) == 0) {
+ printf STDERR
+ gettext("%s: no processor groups matching command line arguments %s\n"),
+ $cmdname, "@ARGV";
+ exit(E_ERROR);
+}
+
+#
+# Global list of PGs that should be excluded from the output - it is only used
+# when tree mode is specified.
+#
+my @exclude_pgs;
+if ($do_tree) {
+ @exclude_pgs = grep {
+ list_match($p->sh_name($_), @sharing_filter_neg)
+ } @all_pgs;
+
+ #
+ # In tree mode add PGs that are in the lineage of given PGs
+ #
+ @pgs = pg_lineage($p, @pgs)
+}
+
+#
+# -I is specified, print list of all PGs
+#
+if ($script_mode) {
+ if (scalar(@pgs)) {
+ @pgs = sort { $a <=> $b } @pgs;
+ print "@pgs\n";
+ } else {
+ print "none\n";
+ }
+ exit($rc);
+}
+
+#
+# -C is specified, print list of all CPUs belonging to PGs
+#
+if ($do_cpulist) {
+ my @cpu_list = $p->uniqsort(map { $p->cpus($_) } @pgs);
+ print "@cpu_list\n";
+ exit($rc);
+}
+
+# Mapping of relationships to list of PGs
+my %pgs_by_relationship;
+
+# Maximum length of all sharing names
+my $max_sharename_len = length('RELATIONSHIP');
+
+# Maximum length of PG ID
+my $max_pg_len = length(max(@pgs)) + 1;
+
+#
+# For calculating proper offsets we need to know minimum and maximum level for
+# all PGs
+#
+my @levels = map { $p->level($_) } @pgs;
+my $maxlevel = max(@levels);
+my $minlevel = min(@levels);
+
+# Calculate maximum string length that should be used to represent PGs
+foreach my $pg (@pgs) {
+ my $name = $p->sh_name ($pg) || "unknown";
+ my $level = $p->level($pg) || 0;
+
+ if ($do_physical) {
+ my $tags = $p->tags($pg);
+ $name = "$name [$tags]" if $tags;
+ }
+
+ my $length = length($name) + $level - $minlevel;
+ $max_sharename_len = $length if $length > $max_sharename_len;
+}
+
+if ($do_sharing_only) {
+ #
+ # -s - only print sharing relationships
+
+ # Get list of sharing relationships
+ my @relationships = $p->sharing_relationships(@pgs);
+
+ if ($verbose) {
+ printf "%-${max_sharename_len}s %s\n",
+ 'RELATIONSHIP', 'PGs';
+ foreach my $rel (@relationships) {
+ my @pg_rel = grep { $p->sh_name($_) eq $rel }
+ @pgs;
+ my $pg_rel = $p->id_collapse (@pg_rel);
+ $pgs_by_relationship{$rel} = \@pg_rel;
+ }
+ }
+
+ foreach my $rel (@relationships) {
+ printf "%-${max_sharename_len}s", $rel;
+ if ($verbose) {
+ my @pgs = @{$pgs_by_relationship{$rel}};
+ my $pgs = $p->id_collapse (@pgs);
+ print ' ', $pgs;
+ }
+ print "\n";
+ }
+
+ # we are done
+ exit($rc);
+}
+
+#
+# Print PGs either in list form or tree form
+#
+if (!$do_tree) {
+ my $header;
+
+ $header = sprintf "%-${max_pg_len}s %-${max_sharename_len}s" .
+ " %s\n",
+ 'PG', 'RELATIONSHIP', 'CPUs';
+
+ print $header;
+ map { pg_print ($p, $_) } @pgs;
+} else {
+ #
+ # Construct a tree from PG hierarchy and prune any PGs that are
+ # specified with -R option
+ #
+ my $pg_tree = pg_make_tree($p);
+ map { pg_remove_from_tree($pg_tree, $_) } @exclude_pgs;
+
+ # Find top-level PGs
+ my @top_level = grep {
+ $pg_tree->{$_} && !defined($pg_tree->{$_}->{parent})
+ } @pgs;
+
+ # Print each top-level node as ASCII tree
+ foreach my $pg (@top_level) {
+ my $children = $pg_tree->{$pg}->{children};
+ my @children = $children ? @{$children} : ();
+ @children = $p->intersect(\@children, \@pgs);
+ pg_print_tree($p, $pg_tree, $pg, '', '', scalar @children);
+ }
+}
+
+# We are done!
+exit($rc);
+
+######################################################################
+# Internal functions
+#
+
+#
+# pg_print(cookie, pg)
+# print PG information in list mode
+#
+sub pg_print
+{
+ my $p = shift;
+ my $pg = shift;
+ my $sharing = $p->sh_name($pg);
+ if ($do_physical) {
+ my $tags = $p->tags($pg);
+ $sharing = "$sharing [$tags]" if $tags;
+ }
+ my $level = $p->level($pg) - $minlevel;
+ $sharing = (' ' x (LEVEL_OFFSET * $level)) . $sharing;
+ my $cpus = $p->cpus($pg);
+ printf "%-${max_pg_len}d %-${max_sharename_len}s", $pg, $sharing;
+ print " $cpus";
+ print "\n";
+}
+
+#
+# pg_showcpus(cookie, pg)
+# Print CPUs in the current PG
+#
+sub pg_showcpus
+{
+ my $p = shift;
+ my $pg = shift;
+
+ my @cpus = $p->cpus($pg);
+ my $ncpus = scalar @cpus;
+ return 0 unless $ncpus;
+ my $cpu_string = $p->cpus($pg);
+ return (($ncpus == 1) ?
+ "CPU: $cpu_string":
+ "CPUs: $cpu_string");
+}
+
+#
+# pg_print_node(cookie, pg)
+# print PG as ASCII tree node
+#
+sub pg_print_node
+{
+ my $p = shift;
+ my $pg = shift;
+
+ my $sharing = $p->sh_name($pg);
+ if ($do_physical) {
+ my $tags = $p->tags($pg);
+ $sharing = "$sharing [$tags]" if $tags;
+ }
+
+ print "$pg ($sharing)";
+ my $cpus = pg_showcpus($p, $pg);
+ print " $cpus";
+ print "\n";
+}
+
+#
+# pg_print_tree(cookie, tree, pg, prefix, childprefix, npeers)
+# print ASCII tree of PGs in the tree
+# prefix should be used for the current node, childprefix for children nodes
+# npeers is the number of peers of the current node
+#
+sub pg_print_tree
+{
+ my $p = shift;
+ my $pg_tree = shift;
+ my $pg = shift;
+ return unless defined ($pg); # done!
+ my $prefix = shift;
+ my $childprefix = shift;
+ my $npeers = shift;
+
+ # Get list of my children
+ my $children = $pg_tree->{$pg}->{children};
+ my @children = $children ? @{$children} : ();
+ @children = $p->intersect(\@children, \@pgs);
+ my $nchildren = scalar @children;
+
+ my $printprefix = "$childprefix";
+ my $printpostfix = $npeers ? "| " : " ";
+
+ my $bar = $npeers ? "|" : "`";
+
+ print $childprefix ? $childprefix : "";
+ print $prefix ? "$bar" . "-- " : "";
+ pg_print_node ($p, $pg);
+
+ my $new_prefix = $npeers ? $prefix : " ";
+
+ # Print the subtree with a new offset, starting from each child
+ map {
+ pg_print_tree($p, $pg_tree, $_, "| ",
+ "$childprefix$new_prefix", --$nchildren)
+ } @children;
+}
+
+#
+# list_match(arg, list)
+# Return arg if argument matches any of the elements on the list
+#
+sub list_match
+{
+ my $arg = shift;
+
+ return first { $arg =~ m/$_/i } @_;
+}
+
+#
+# Make a version of PG parent-children relationships from cookie
+#
+sub pg_make_tree
+{
+ my $p = shift;
+ my $pg_tree = ();
+
+ foreach my $pg ($p->all()) {
+ my @children = $p->children($pg);
+ $pg_tree->{$pg}->{parent} = $p->parent($pg);
+ $pg_tree->{$pg}->{children} = \@children;
+ }
+
+ return ($pg_tree);
+}
+
+#
+# pg_remove_from_tree(tree, pg)
+# Prune PG from the tree
+#
+sub pg_remove_from_tree
+{
+ my $pg_tree = shift;
+ my $pg = shift;
+ my $node = $pg_tree->{$pg};
+ return unless $node;
+
+ my @children = @{$node->{children}};
+ my $parent = $node->{parent};
+ my $parent_node;
+
+ #
+ # Children have a new parent
+ #
+ map { $pg_tree->{$_}->{parent} = $parent } @children;
+
+ #
+ # All children move to the parent (if there is one)
+ #
+ if (defined($parent) && ($parent_node = $pg_tree->{$parent})) {
+ #
+ # Merge children from parent and @children list
+ #
+ my @parent_children = @{$parent_node->{children}};
+ #
+ # Remove myself from parent children
+ #
+ @parent_children = grep { $_ != $pg } @parent_children;
+ @parent_children = $p->nsort(@parent_children, @children);
+ $parent_node->{children} = \@parent_children;
+ }
+
+ # Remove current node
+ delete $pg_tree->{$pg};
+}
+
+#
+# For a given list of PGs return the full lineage
+#
+sub pg_lineage
+{
+ my $p = shift;
+ return unless scalar @_;
+
+ my @parents = grep { defined($_) } map { $p->parent ($_) } @_;
+
+ return ($p->uniq(@_, @parents, pg_lineage ($p, @parents)));
+}
+
+#
+# Print usage information and exit with the return code specified
+#
+sub usage
+{
+ my $rc = shift;
+ printf STDERR
+ gettext("Usage:\t%s [-T] [-p] [-v] [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"),
+ $cmdname;
+ printf STDERR
+ gettext("\t%s -s [-v] [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"), $cmdname;
+ printf STDERR gettext("\t%s -C | -I [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"),
+ $cmdname;
+ printf STDERR gettext("\t%s -h\n\n"), $cmdname;
+
+ exit($rc);
+}
+
+__END__
generated by cgit v1.2.3 (git 2.46.0) at 2025-12-03 02:27:08 +0000