usr/src/cmd/pginfo/pginfo.pl

   1 #! /usr/perl5/bin/perl
   2 #
   3 # CDDL HEADER START
   4 #
   5 # The contents of this file are subject to the terms of the
   6 # Common Development and Distribution License (the "License").
   7 # You may not use this file except in compliance with the License.
   8 #
   9 # You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
  10 # or http://www.opensolaris.org/os/licensing.
  11 # See the License for the specific language governing permissions
  12 # and limitations under the License.
  13 #
  14 # When distributing Covered Code, include this CDDL HEADER in each
  15 # file and include the License file at usr/src/OPENSOLARIS.LICENSE.
  16 # If applicable, add the following below this CDDL HEADER, with the
  17 # fields enclosed by brackets "[]" replaced with your own identifying
  18 # information: Portions Copyright [yyyy] [name of copyright owner]
  19 #
  20 # CDDL HEADER END
  21 #
  22
  23 #
  24 # Copyright (c) 2010, Oracle and/or its affiliates. All rights reserved.
  25 #
  26
  27 #
  28 # pginfo - tool for displaying Processor Group information
  29 #
  30
  31 use warnings;
  32 use strict;
  33 use File::Basename;
  34 use Errno;
  35 use POSIX qw(locale_h);
  36 use Getopt::Long qw(:config no_ignore_case bundling auto_version);
  37 use List::Util qw(first max min);
  38 use Sun::Solaris::Utils qw(textdomain gettext);
  39 use Sun::Solaris::Pg;
  40
  41 #
  42 # Constants
  43 #
  44 # It is possible that wnen trying to parse PG information, PG generation changes
  45 # which will cause PG new method to fail with errno set to EAGAIN In this case
  46 # we retry open up to RETRY_COUNT times pausing RETRY_DELAY seconds between each
  47 # retry.
  48 #
  49 # When printing PGs we print them as a little tree with each PG shifted by
  50 # LEVEL_OFFSET from each parent. For example:
  51 #
  52 # PG  RELATIONSHIP                    CPUs
  53 # 0   System                          0-7
  54 # 3    Socket                         0 2 4 6
  55 # 2     Cache                         0 2 4 6
  56 #
  57
  58 use constant {
  59         VERSION         => 1.1,
  60         LEVEL_OFFSET    => 1,
  61         RETRY_COUNT     => 4,
  62         RETRY_DELAY     => 0.25,
  63 };
  64
  65 #
  66 # Return codes
  67 #
  68 #     0    Successful completion.
  69 #
  70 #     1    An error occurred.
  71 #
  72 #     2    Invalid command-line options were specified.
  73 #
  74 use constant {
  75         E_SUCCESS => 0,
  76         E_ERROR => 1,
  77         E_USAGE => 2,
  78 };
  79
  80
  81 # Set message locale
  82 setlocale(LC_ALL, "");
  83 textdomain(TEXT_DOMAIN);
  84
  85 # Get script name for error messages
  86 our $cmdname = basename($0, ".pl");
  87
  88 #
  89 # Process options
  90 #
  91 my $do_cpulist;                 # -C - Show CPU IDs
  92 my $do_cpus;                    # -c - Treat args as CPU IDs
  93 my $do_physical;                # -p - Show physical relationships
  94 my $do_sharing_only;            # -S - Only show sharing relationships
  95 my $do_tree;                    # -T - Show ASCII tree
  96 my $do_usage;                   # -h - Show usage
  97 my $do_version;                 # -V - Show version
  98 my $script_mode;                # -I - Only show IDs
  99 my $verbose = 0;                # -v - Verbose output
 100 my @sharing_filter;             # -r string,...
 101 my @sharing_filter_neg;         # -R string,...
 102
 103 # Exit code
 104 my $rc = E_SUCCESS;
 105
 106 # Parse options from the command line
 107 GetOptions("cpus|c"             => \$do_cpus,
 108            "idlist|I"           => \$script_mode,
 109            "cpulist|C"          => \$do_cpulist,
 110            "physical|p"         => \$do_physical,
 111            "help|h|?"           => \$do_usage,
 112            "sharing|s"          => \$do_sharing_only,
 113            "relationship|r=s"   => \@sharing_filter,
 114            "norelationship|R=s" => \@sharing_filter_neg,
 115            "tree|topology|T"    => \$do_tree,
 116            "version|V"          => \$do_version,
 117            "verbose+"           => \$verbose,
 118            "v+"                 => \$verbose,
 119 ) || usage(E_USAGE);
 120
 121 # Print usage message when -h is given
 122 usage(E_SUCCESS) if $do_usage;
 123
 124 if ($do_version) {
 125         #
 126         # Print version information and exit
 127         #
 128         printf gettext("%s version %s\n"), $cmdname, VERSION;
 129         exit(E_SUCCESS);
 130 }
 131
 132 #
 133 # Verify options compatibility
 134 #
 135 if ($script_mode && $do_cpulist) {
 136         printf STDERR
 137           gettext("%s: options -I and -C can not be used at the same time\n"),
 138             $cmdname;
 139         usage(E_USAGE);
 140 }
 141
 142 if (($script_mode || $do_cpulist) &&
 143     ($do_physical || $do_sharing_only ||
 144     $do_tree)) {
 145         printf STDERR
 146           gettext("%s: options -C and -I can not be used with -p -s or -T\n"),
 147             $cmdname;
 148         usage(E_USAGE);
 149 }
 150
 151 if ($do_physical && $do_sharing_only) {
 152         printf STDERR
 153           gettext("%s: option -p can not be used with -s\n"), $cmdname;
 154         usage(E_USAGE);
 155 }
 156
 157 if ($do_tree && $do_sharing_only) {
 158         printf STDERR
 159           gettext("%s: option -T can not be used with -s\n"),
 160             $cmdname;
 161         usage(E_USAGE);
 162 }
 163
 164 if ($verbose && !($script_mode || $do_cpulist || $do_sharing_only)) {
 165         $do_tree = 1;
 166         $do_physical = 1;
 167 }
 168
 169 #
 170 # Get PG information
 171 #
 172 my $p = Sun::Solaris::Pg->new(-tags => $do_physical,
 173                               -retry => RETRY_COUNT,
 174                               '-delay' => RETRY_DELAY);
 175
 176 if (!$p) {
 177         printf STDERR
 178           gettext("%s: can not obtain Processor Group information: $!\n"),
 179             $cmdname;
 180         exit(E_ERROR);
 181 }
 182
 183 #
 184 # Convert -[Rr] string1,string2,... into list (string1, string2, ...)
 185 #
 186 @sharing_filter = map { split /,/ } @sharing_filter;
 187 @sharing_filter_neg = map { split /,/ } @sharing_filter_neg;
 188
 189 #
 190 # Get list of all PGs in the system
 191 #
 192 my @all_pgs = $p->all_depth_first();
 193
 194 if (scalar(@all_pgs) == 0) {
 195         printf STDERR
 196           gettext("%s: this system does not have any Processor groups\n"),
 197             $cmdname;
 198         exit(E_ERROR);
 199 }
 200
 201 #
 202 # @pgs is the list of PGs we are going to work with after all the option
 203 # processing
 204 #
 205 my @pgs = @all_pgs;
 206
 207 #
 208 # get list of all CPUs in the system by looking at the root PG cpus
 209 #
 210 my @all_cpus = $p->cpus($p->root());
 211
 212 #
 213 # If there are arguments in the command line, treat them as either PG IDs or as
 214 # CPUs that should be converted to PG IDs.
 215 # Arguments can be specified as x-y x,y,z and use special keyword 'all'
 216 #
 217 if (scalar @ARGV) {
 218         #
 219         # Convert 'all' in arguments to all CPUs or all PGs
 220         #
 221         my @args;
 222         my @all = $do_cpus ? @all_cpus : @all_pgs;
 223         @args = map { $_ eq 'all' ? @all : $_ } @ARGV;
 224
 225         # Expand any x-y,z ranges
 226         @args =  $p->expand(@args);
 227
 228         if ($do_cpus) {
 229                 # @bad_cpus is a list of invalid CPU IDs
 230                 my @bad_cpus =  $p->set_subtract(\@all_cpus, \@args);
 231                 if (scalar @bad_cpus) {
 232                         printf STDERR
 233                           gettext("%s: Invalid processor IDs %s\n"),
 234                             $cmdname, $p->id_collapse(@bad_cpus);
 235                         $rc = E_ERROR;
 236                 }
 237                 #
 238                 # List of PGs is the list of any PGs that contain specified CPUs
 239                 #
 240                 @pgs = grep {
 241                         my @cpus = $p->cpus($_);
 242                         scalar($p->intersect(\@cpus, \@args));
 243                 } @all_pgs;
 244         } else {
 245                 # @pgs is a list of valid CPUs in the arguments
 246                 @pgs = $p->intersect(\@all_pgs, \@args);
 247                 # @bad_pgs is a list of invalid PG IDs
 248                 my @bad_pgs = $p->set_subtract(\@all_pgs, \@args);
 249                 if (scalar @bad_pgs) {
 250                         printf STDERR
 251                           gettext("%s: Invalid PG IDs %s\n"),
 252                             $cmdname, $p->id_collapse(@bad_pgs);
 253                         $rc = E_ERROR;
 254                 }
 255         }
 256 }
 257
 258 #
 259 # Now we have list of PGs to work with. Now apply filtering. First list only
 260 # those matching -R
 261 #
 262 @pgs = grep { list_match($p->sh_name($_), @sharing_filter) } @pgs if
 263   scalar @sharing_filter;
 264
 265 # Remove any that doesn't match -r
 266 @pgs = grep { !list_match($p->sh_name($_), @sharing_filter_neg) } @pgs if
 267   scalar @sharing_filter_neg;
 268
 269 # Do we have any PGs left?
 270 if (scalar(@pgs) == 0) {
 271         printf STDERR
 272         gettext("%s: no processor groups matching command line arguments %s\n"),
 273             $cmdname, "@ARGV";
 274         exit(E_ERROR);
 275 }
 276
 277 #
 278 # Global list of PGs that should be excluded from the output - it is only used
 279 # when tree mode is specified.
 280 #
 281 my @exclude_pgs;
 282 if ($do_tree) {
 283         @exclude_pgs = grep {
 284                 list_match($p->sh_name($_), @sharing_filter_neg)
 285         } @all_pgs;
 286
 287         #
 288         # In tree mode add PGs that are in the lineage of given PGs
 289         #
 290         @pgs = pg_lineage($p, @pgs)
 291 }
 292
 293 #
 294 # -I is specified, print list of all PGs
 295 #
 296 if ($script_mode) {
 297         if (scalar(@pgs)) {
 298                 @pgs = sort { $a <=> $b } @pgs;
 299                 print "@pgs\n";
 300         } else {
 301                 print "none\n";
 302         }
 303         exit($rc);
 304 }
 305
 306 #
 307 # -C is specified, print list of all CPUs belonging to PGs
 308 #
 309 if ($do_cpulist) {
 310         my @cpu_list = $p->uniqsort(map { $p->cpus($_) } @pgs);
 311         print "@cpu_list\n";
 312         exit($rc);
 313 }
 314
 315 # Mapping of relationships to list of PGs
 316 my %pgs_by_relationship;
 317
 318 # Maximum length of all sharing names
 319 my $max_sharename_len = length('RELATIONSHIP');
 320
 321 # Maximum length of PG ID
 322 my $max_pg_len = length(max(@pgs)) + 1;
 323
 324 #
 325 # For calculating proper offsets we need to know minimum and maximum level for
 326 # all PGs
 327 #
 328 my @levels = map { $p->level($_) } @pgs;
 329 my $maxlevel = max(@levels);
 330 my $minlevel = min(@levels);
 331
 332 # Calculate maximum string length that should be used to represent PGs
 333 foreach my $pg (@pgs) {
 334         my $name =  $p->sh_name ($pg) || "unknown";
 335         my $level = $p->level($pg) || 0;
 336
 337         if ($do_physical) {
 338                 my $tags = $p->tags($pg);
 339                 $name = "$name [$tags]" if $tags;
 340         }
 341
 342         my $length = length($name) + $level - $minlevel;
 343         $max_sharename_len = $length if $length > $max_sharename_len;
 344 }
 345
 346 if ($do_sharing_only) {
 347         #
 348         # -s - only print sharing relationships
 349
 350         # Get list of sharing relationships
 351         my @relationships = $p->sharing_relationships(@pgs);
 352
 353         if ($verbose) {
 354                 printf "%-${max_sharename_len}s %s\n",
 355                   'RELATIONSHIP', 'PGs';
 356                 foreach my $rel (@relationships) {
 357                         my @pg_rel = grep { $p->sh_name($_) eq $rel }
 358                           @pgs;
 359                         my $pg_rel = $p->id_collapse (@pg_rel);
 360                         $pgs_by_relationship{$rel} = \@pg_rel;
 361                 }
 362         }
 363
 364         foreach my $rel (@relationships) {
 365                 printf "%-${max_sharename_len}s", $rel;
 366                 if ($verbose) {
 367                         my @pgs = @{$pgs_by_relationship{$rel}};
 368                         my $pgs = $p->id_collapse (@pgs);
 369                         print ' ', $pgs;
 370                 }
 371                 print "\n";
 372         }
 373
 374         # we are done
 375         exit($rc);
 376 }
 377
 378 #
 379 # Print PGs either in list form or tree form
 380 #
 381 if (!$do_tree) {
 382         my $header;
 383
 384         $header = sprintf "%-${max_pg_len}s %-${max_sharename_len}s" .
 385           "   %s\n",
 386             'PG', 'RELATIONSHIP', 'CPUs';
 387
 388         print $header;
 389         map { pg_print ($p, $_) } @pgs;
 390 } else {
 391         #
 392         # Construct a tree from PG hierarchy and prune any PGs that are
 393         # specified with -R option
 394         #
 395         my $pg_tree = pg_make_tree($p);
 396         map { pg_remove_from_tree($pg_tree, $_) } @exclude_pgs;
 397
 398         # Find top-level PGs
 399         my @top_level = grep {
 400                 $pg_tree->{$_} && !defined($pg_tree->{$_}->{parent})
 401         } @pgs;
 402
 403         # Print each top-level node as ASCII tree
 404         foreach my $pg (@top_level) {
 405                 my $children = $pg_tree->{$pg}->{children};
 406                 my @children = $children ? @{$children} : ();
 407                 @children = $p->intersect(\@children, \@pgs);
 408                 pg_print_tree($p, $pg_tree, $pg, '', '', scalar @children);
 409         }
 410 }
 411
 412 # We are done!
 413 exit($rc);
 414
 415 ######################################################################
 416 # Internal functions
 417 #
 418
 419 #
 420 # pg_print(cookie, pg)
 421 # print PG information in list mode
 422 #
 423 sub pg_print
 424 {
 425         my $p = shift;
 426         my $pg = shift;
 427         my $sharing = $p->sh_name($pg);
 428         if ($do_physical) {
 429                 my $tags = $p->tags($pg);
 430                 $sharing = "$sharing [$tags]" if $tags;
 431         }
 432         my $level = $p->level($pg) - $minlevel;
 433         $sharing = (' ' x (LEVEL_OFFSET * $level)) . $sharing;
 434         my $cpus = $p->cpus($pg);
 435         printf "%-${max_pg_len}d %-${max_sharename_len}s", $pg, $sharing;
 436         print "   $cpus";
 437         print "\n";
 438 }
 439
 440 #
 441 # pg_showcpus(cookie, pg)
 442 # Print CPUs in the current PG
 443 #
 444 sub pg_showcpus
 445 {
 446         my $p = shift;
 447         my $pg = shift;
 448
 449         my @cpus = $p->cpus($pg);
 450         my $ncpus = scalar @cpus;
 451         return 0 unless $ncpus;
 452         my $cpu_string = $p->cpus($pg);
 453         return (($ncpus == 1) ?
 454                 "CPU: $cpu_string":
 455                 "CPUs: $cpu_string");
 456 }
 457
 458 #
 459 # pg_print_node(cookie, pg)
 460 # print PG as ASCII tree node
 461 #
 462 sub pg_print_node
 463 {
 464         my $p = shift;
 465         my $pg = shift;
 466
 467         my $sharing = $p->sh_name($pg);
 468         if ($do_physical) {
 469                 my $tags = $p->tags($pg);
 470                 $sharing = "$sharing [$tags]" if $tags;
 471         }
 472
 473         print "$pg ($sharing)";
 474         my $cpus = pg_showcpus($p, $pg);
 475         print " $cpus";
 476         print "\n";
 477 }
 478
 479 #
 480 # pg_print_tree(cookie, tree, pg, prefix, childprefix, npeers)
 481 # print ASCII tree of PGs in the tree
 482 # prefix should be used for the current node, childprefix for children nodes
 483 # npeers is the number of peers of the current node
 484 #
 485 sub pg_print_tree
 486 {
 487         my $p = shift;
 488         my $pg_tree = shift;
 489         my $pg = shift;
 490         return unless defined ($pg);    # done!
 491         my $prefix = shift;
 492         my $childprefix = shift;
 493         my $npeers = shift;
 494
 495         # Get list of my children
 496         my $children = $pg_tree->{$pg}->{children};
 497         my @children = $children ? @{$children} : ();
 498         @children = $p->intersect(\@children, \@pgs);
 499         my $nchildren = scalar @children;
 500
 501         my $printprefix = "$childprefix";
 502         my $printpostfix = $npeers ? "|   " : "    ";
 503
 504         my $bar = $npeers ? "|" : "`";
 505
 506         print $childprefix ? $childprefix : "";
 507         print $prefix ? "$bar" . "-- " : "";
 508         pg_print_node ($p, $pg);
 509
 510         my $new_prefix = $npeers ? $prefix : "    ";
 511
 512         # Print the subtree with a new offset, starting from each child
 513         map {
 514                 pg_print_tree($p, $pg_tree, $_, "|   ",
 515                       "$childprefix$new_prefix", --$nchildren)
 516         } @children;
 517 }
 518
 519 #
 520 # list_match(arg, list)
 521 # Return arg if argument matches any of the elements on the list
 522 #
 523 sub list_match
 524 {
 525         my $arg = shift;
 526
 527         return first { $arg =~ m/$_/i } @_;
 528 }
 529
 530 #
 531 # Make a version of PG parent-children relationships from cookie
 532 #
 533 sub pg_make_tree
 534 {
 535         my $p = shift;
 536         my $pg_tree = ();
 537
 538         foreach my $pg ($p->all()) {
 539                 my @children = $p->children($pg);
 540                 $pg_tree->{$pg}->{parent} = $p->parent($pg);
 541                 $pg_tree->{$pg}->{children} = \@children;
 542         }
 543
 544         return ($pg_tree);
 545 }
 546
 547 #
 548 # pg_remove_from_tree(tree, pg)
 549 # Prune PG from the tree
 550 #
 551 sub pg_remove_from_tree
 552 {
 553         my $pg_tree = shift;
 554         my $pg = shift;
 555         my $node = $pg_tree->{$pg};
 556         return unless $node;
 557
 558         my @children = @{$node->{children}};
 559         my $parent = $node->{parent};
 560         my $parent_node;
 561
 562         #
 563         # Children have a new parent
 564         #
 565         map { $pg_tree->{$_}->{parent} = $parent } @children;
 566
 567         #
 568         # All children move to the parent (if there is one)
 569         #
 570         if (defined($parent) && ($parent_node = $pg_tree->{$parent})) {
 571                 #
 572                 # Merge children from parent and @children list
 573                 #
 574                 my @parent_children = @{$parent_node->{children}};
 575                 #
 576                 # Remove myself from parent children
 577                 #
 578                 @parent_children = grep { $_ != $pg } @parent_children;
 579                 @parent_children = $p->nsort(@parent_children, @children);
 580                 $parent_node->{children} = \@parent_children;
 581         }
 582
 583         # Remove current node
 584         delete $pg_tree->{$pg};
 585 }
 586
 587 #
 588 # For a given list of PGs return the full lineage
 589 #
 590 sub pg_lineage
 591 {
 592         my $p = shift;
 593         return unless scalar @_;
 594
 595         my @parents = grep { defined($_) } map { $p->parent ($_) } @_;
 596
 597         return ($p->uniq(@_, @parents, pg_lineage ($p, @parents)));
 598 }
 599
 600 #
 601 # Print usage information and exit with the return code specified
 602 #
 603 sub usage
 604 {
 605         my $rc = shift;
 606         printf STDERR
 607           gettext("Usage:\t%s [-T] [-p] [-v] [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"),
 608             $cmdname;
 609         printf STDERR
 610           gettext("\t%s -s [-v] [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"), $cmdname;
 611         printf STDERR gettext("\t%s -C | -I [-r string] [-R string] [pg ... | -c processor_id ...]\n\n"),
 612           $cmdname;
 613         printf STDERR gettext("\t%s -h\n\n"), $cmdname;
 614
 615         exit($rc);
 616 }
 617
 618 __END__