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 31use warnings; 32use strict; 33use File::Basename; 34use Errno; 35use POSIX qw(locale_h); 36use Getopt::Long qw(:config no_ignore_case bundling auto_version); 37use List::Util qw(first max min); 38use Sun::Solaris::Utils qw(textdomain gettext); 39use 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 58use 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# 74use constant { 75 E_SUCCESS => 0, 76 E_ERROR => 1, 77 E_USAGE => 2, 78}; 79 80 81# Set message locale 82setlocale(LC_ALL, ""); 83textdomain(TEXT_DOMAIN); 84 85# Get script name for error messages 86our $cmdname = basename($0, ".pl"); 87 88# 89# Process options 90# 91my $do_cpulist; # -C - Show CPU IDs 92my $do_cpus; # -c - Treat args as CPU IDs 93my $do_physical; # -p - Show physical relationships 94my $do_sharing_only; # -S - Only show sharing relationships 95my $do_tree; # -T - Show ASCII tree 96my $do_usage; # -h - Show usage 97my $do_version; # -V - Show version 98my $script_mode; # -I - Only show IDs 99my $verbose = 0; # -v - Verbose output 100my @sharing_filter; # -r string,... 101my @sharing_filter_neg; # -R string,... 102 103# Exit code 104my $rc = E_SUCCESS; 105 106# Parse options from the command line 107GetOptions("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 122usage(E_SUCCESS) if $do_usage; 123 124if ($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# 135if ($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 142if (($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 151if ($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 157if ($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 164if ($verbose && !($script_mode || $do_cpulist || $do_sharing_only)) { 165 $do_tree = 1; 166 $do_physical = 1; 167} 168 169# 170# Get PG information 171# 172my $p = Sun::Solaris::Pg->new(-tags => $do_physical, 173 -retry => RETRY_COUNT, 174 '-delay' => RETRY_DELAY); 175 176if (!$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# 192my @all_pgs = $p->all_depth_first(); 193 194if (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# 205my @pgs = @all_pgs; 206 207# 208# get list of all CPUs in the system by looking at the root PG cpus 209# 210my @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# 217if (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? 270if (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# 281my @exclude_pgs; 282if ($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# 296if ($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# 309if ($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 316my %pgs_by_relationship; 317 318# Maximum length of all sharing names 319my $max_sharename_len = length('RELATIONSHIP'); 320 321# Maximum length of PG ID 322my $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# 328my @levels = map { $p->level($_) } @pgs; 329my $maxlevel = max(@levels); 330my $minlevel = min(@levels); 331 332# Calculate maximum string length that should be used to represent PGs 333foreach 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 346if ($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# 381if (!$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! 413exit($rc); 414 415###################################################################### 416# Internal functions 417# 418 419# 420# pg_print(cookie, pg) 421# print PG information in list mode 422# 423sub 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# 444sub 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# 462sub 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# 485sub 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# 523sub 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# 533sub 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# 551sub 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# 590sub 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# 603sub 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__ 619