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 2008 Sun Microsystems, Inc.  All rights reserved.
25# Use is subject to license terms.
26#
27# ident	"%Z%%M%	%I%	%E% SMI"
28#
29
30require 5.8.0;
31use strict;
32use warnings;
33
34# Make sure that Lgrp test is not executed on anything less than 5.8.0,
35# as Lgrp is not implemented there
36BEGIN {
37	if ($] < 5.008) {
38		# Fake one successfull test and exit
39		printf "1..1\nok\n";
40		exit 0;
41	}
42}
43
44######################################################################
45# Tests for Sun::Solaris::Lgrp API.
46#
47# This is an example script that demonstrates use of Sun::Solaris::Lgrp module.
48# It can be used to test the module itself, the liblgrp library or the in-kernel
49# implementation.
50######################################################################
51
52#                       Tests to run
53use Test::More tests => 33;
54
55# Verify that we can load the module
56BEGIN { use_ok('Sun::Solaris::Lgrp') };
57
58use Sun::Solaris::Lgrp ':ALL';
59
60my ($home, $fail);
61
62######################################################################
63# Verify that lgrp_init() works.
64##
65my $c = Sun::Solaris::Lgrp->new(LGRP_VIEW_OS);
66ok($c, 'lgrp_init') or die("lgrp_init: $!");
67#
68######################################################################
69
70######################################################################
71# root should have ID 0.
72##
73my $root = $c->root;
74is($root, 0, 'root should have id zero');
75
76#
77######################################################################
78# Verify lgrp_nlgrps()
79##
80my $nlgrps = $c->nlgrps;
81ok($nlgrps, 'lgrp_nlgrps') or
82    diag("lgrp_nlgrps: $!");
83
84my $is_numa = ($nlgrps > 1);
85
86my @lgrps = $c->lgrps;
87ok(scalar @lgrps, 'Can get lgrps list') or
88    diag("lgrp_lgrps: $!");
89
90is(scalar @lgrps, $nlgrps, 'lgrp_nlgrps() should match number of lgrps');
91
92######################################################################
93# All root children should have root as their one and only one parent
94##
95$fail = 0;
96my (@children) = $c->children($root);
97my @leaves = $c->leaves;
98ok(@leaves, 'There are some leaves');
99
100cmp_ok(@children, '<=', @leaves, 'Root should have nchildren <= nleaves');
101my @parents;
102
103foreach my $l (@children) {
104    (@parents) = $c->parents($l) or
105	diag("lgrp_parents: $!");
106    my $nparents = @parents;
107    my ($parent, @rest) = @parents;
108    $fail++ if $parent != $root;
109    $fail++ unless $nparents == 1;
110}
111is($fail, 0, 'correct parents for children');
112
113######################################################################
114# Each lgrp other than root should have a single parent and
115# root should have no parents.
116##
117
118$fail = 0;
119foreach my $l (lgrp_lgrps($c)) {
120    next if $l == $root;
121    my (@parents) = $c->parents($l) or
122	diag("lgrp_parents: $!");
123    my $nparents = @parents;
124    $fail++ unless $nparents == 1;
125}
126is($fail, 0, 'All non-leaf lgrps should have single parent');
127
128@parents = $c->parents($root);
129ok(!@parents, 'root should have no parents');
130#
131#######################################################################
132
133######################################################################
134# Lgrp affinity tests.
135#######################
136
137######################################################################
138# lgrp_affinity-set should change home lgrp.
139##
140SKIP: {
141    skip 'Test only valid on NUMA platform', 1 unless $is_numa;
142    my $leaf = $leaves[0];	# Pickup any non-root lgrp.
143    $home = $c->home(P_PID, P_MYID);
144
145    # Pickup any lgrp not equal to the current one.
146    my $lgrp = ($home == $root ? $leaf : $root);
147    # Set affinity to the new lgrp.
148    $c->affinity_set(P_PID, P_MYID, $lgrp, LGRP_AFF_STRONG) or
149	diag("lgrp_affinity_set(): $!");
150    # Our home should change to a new lgrp.
151    $home = $c->home(P_PID, P_MYID);
152    is($home, $lgrp, 'Home lgrp should change after strong affinity is set');
153    # Drop affinity to the lgrp.
154    $c->affinity_set(P_PID, P_MYID, $lgrp, LGRP_AFF_NONE) or
155	diag("lgrp_affinity_set(): $!");
156}
157
158######################################################################
159# Should be able to set affinity to any legal value
160##
161
162my @affs = (LGRP_AFF_WEAK, LGRP_AFF_STRONG, LGRP_AFF_NONE);
163
164foreach my $aff (@affs) {
165    $c->affinity_set(P_PID, P_MYID, $root, $aff) or
166	diag("lgrp_affinity_set(): $!");
167    my $affinity = $c->affinity_get(P_PID, $$, $root);
168    is($affinity, $aff, "affinity should be $aff");
169}
170
171#
172######################################################################
173
174######################################################################
175# Root should have non-zero CPUs and memory size
176# Also, its memory size should be consistent with the one reported by
177# sysconfig.
178##
179my @rcpus = $c->cpus($root, LGRP_CONTENT_HIERARCHY) or
180    die("lgrp_cpus: $!");
181my $ncpus = @rcpus;
182ok($ncpus, 'there are CPUs in the system');
183
184my $memsize = $c->mem_size($root,
185			    LGRP_MEM_SZ_INSTALLED,
186			   LGRP_CONTENT_HIERARCHY) or
187    diag("lgrp_mem_size(): $!");
188
189ok($memsize, 'memory size is non-zero');
190#
191######################################################################
192
193######################################################################
194# The cookie should not be stale
195is($c->stale, 0, 'Cookie should not be stale');
196#
197######################################################################
198
199######################################################################
200# Latency should be non-zero.
201my $latency = lgrp_latency($root, $root);
202ok(defined $latency, 'lgrp_latency() is working') or
203    diag("lgrp_latency: $!");
204
205my $latency1 = $c->latency($root, $root);
206ok(defined $latency1, 'lgrp_latency_cookie() is working') or
207    diag("lgrp_latency_cookie: $!");
208
209is($latency, $latency1, 'Latencies should match');
210#
211######################################################################
212
213######################################################################
214# Verify latency matrix.
215##
216SKIP: {
217    skip 'Test only valid on NUMA platform', 9 unless $is_numa;
218
219    cmp_ok($latency, '>', 0, "Latency from root to self should be positive");
220    my $latencies;
221    my $min_latency = 10000;
222    my $max_latency = 0;
223    my $badlatency = 0;
224    my $assymetrical = 0;
225    my $diagonalmin = 0;
226    my $badself = 0;
227    my $nlatencies;
228
229    foreach my $l1 (@lgrps) {
230	foreach my $l2 (@lgrps) {
231	    $latencies->{$l1}{$l2} = $c->latency($l1, $l2);
232	    $nlatencies++ if $latencies->{$l1}{$l2};
233	}
234    }
235
236    # There should be at least some lgroups which have latencies.
237    my @d_lgrps = grep { defined $latencies->{$_}{$_} } @leaves;
238    ok(@d_lgrps, 'There should be at least some lgroups which have latencies');
239
240    # All diagonal latencies should be the same.
241    my $lat_diag_lgrp = $d_lgrps[0];
242    my $lat_diag = $latencies->{$lat_diag_lgrp}{$lat_diag_lgrp};
243    my @badlatencies = grep { $latencies->{$_}{$_} != $lat_diag } @d_lgrps;
244    is(scalar @badlatencies, 0, 'All diagonal latencies should be the same') or
245      diag("diagonal latency: $lat_diag; bad latencies: @badlatencies");
246
247    my %l_cpus;
248    my %l_mem;
249    my $lgrps_nomem;
250    my $lgrps_nocpus;
251
252    foreach my $l1 (@lgrps)  {
253	$l_cpus{$l1} = scalar $c->cpus($l1, LGRP_CONTENT_HIERARCHY);
254	$l_mem{$l1}  = $c->mem_size($l1, LGRP_MEM_SZ_INSTALLED,
255				   LGRP_CONTENT_HIERARCHY);
256	$lgrps_nomem++ unless $l_mem{$l1};
257	$lgrps_nocpus++ unless $c->cpus($l1, LGRP_CONTENT_HIERARCHY);
258    }
259
260    # Verify latencies consistency
261    foreach my $l1 (@lgrps) {
262	# Can't get latency if source doesn't have CPUs
263	next unless $l_cpus{$l1};
264	my $self_latency = $latencies->{$l1}{$l1};
265	$lat_diag = $self_latency if $self_latency;
266
267	foreach my $l2 (@lgrps) {
268	    # Can't get latenciy if destination doesn't have memory
269	    next unless $l_mem{$l2};
270
271	    if (! $latencies->{$l1}{$l2}) {
272		$badlatency++;
273		diag("Invalid latency between $l1 and $l2");
274		next;
275	    }
276
277	    $max_latency = $latencies->{$l1}{$l2} if
278		$latencies->{$l1}{$l2} > $max_latency;
279	    $min_latency = $latencies->{$l1}{$l2} if
280		$latencies->{$l1}{$l2} < $min_latency;
281
282	    # Latencies should be symmetrical but only if they are valid.
283	    if ($latencies->{$l2}{$l1} &&
284		$latencies->{$l1}{$l2} != $latencies->{$l2}{$l1}) {
285		$assymetrical++;
286		diag("latency($l1, $l2) != latency($l2, $l1)");
287	    }
288
289	    $diagonalmin++ if $c->isleaf($l1) && $c->isleaf($l2) &&
290		$self_latency && $self_latency > $latencies->{$l1}{$l2};
291	}
292    }
293
294  SKIP: {
295	skip 'Symmetry test only valid if all lgroups have memory and CPUs',
296	  1 if $lgrps_nomem || $lgrps_nocpus;
297    	is($assymetrical,  0, 'Latencies should be symmetrical');
298    }
299
300    is($diagonalmin, 0, 'Latency should be minimal on diagonals');
301    is($badlatency, 0, 'Latency should be defined');
302    is($max_latency, $latencies->{$root}{$root},
303       'Root should have maximum latencies');
304    cmp_ok($min_latency, '>', 0, 'Minimum latency should be positive') if
305	$nlatencies;
306    cmp_ok($min_latency, '<=', $max_latency,
307	   'Minimum latency should be less then maximum') if $nlatencies;
308}
309
310######################################################################
311# Verify lgrp_resources API
312##
313SKIP: {
314    skip 'lgrp_resources() is not supported', 3 if
315	((LGRP_VER_CURRENT == 1) || !$is_numa);
316
317    my @lgrps_c = $c->resources($root, LGRP_RSRC_CPU);
318    ok(scalar @lgrps_c, 'there are CPU resources in the system');
319    $fail = 0;
320    my $nc = 0;
321    foreach my $l (@lgrps_c) {
322	$fail++ unless $c->isleaf($l);
323	my @cpu_l = $c->cpus($l, LGRP_CONTENT_DIRECT);
324	$nc += @cpu_l;
325    }
326    is($fail, 0, 'Each lgrp containing CPU resources should be leaf');
327    is($nc, $ncpus, 'Number of CPUs should match');
328}
329
330#
331######################################################################
332# THE END!
333#########
334