xref: /titanic_52/usr/src/cmd/pginfo/pginfo.pl (revision 6a1af1a67532df169a657cce07140be64bdea084)
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