Sys-CpuAffinity-1.12000755034434000144 013036166657 15127 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/Changes000444034434000144 553413036166656 16565 0ustar00mobrien112general000000000000Revision history for Sys-CpuAffinity 1.12 2017-01-13 Sanity checks on Math::BigInt (RT #118730/Debian #844141) 1.11 2016-11-28 (Untested) support for older solaris (<11.2) with processor_bind(2) Linux sched_getaffinity fixes (RT #118730/Debian #844141) Refactor XS code for FreeBSD 1.10 2016-08-12 Support Multi-CPU Binding through processor_affinity(2) in solaris 11.2 Improved support for linux with >64 cpus 1.09 2016-07-29 Improved support for solaris, including binding to arbitrary subsets of all cores with pbind(1M) Prefer Math::BigInt->new(2)**$n to 1<<$n to support >64 cores. Improved support for aix 1.08 2016-07-22 RT #94560-even more improved support for Linux systems with >32 cpus 1.07 2016-07-22 Improved support for systems with >32 cpus Workaround for overzealous Ubuntu build log filter 1.06 2013-02-01 Prealloc mask strings to avoid buffer overflow in Win32::API calls. 1.05 2011-11-08 Fix issue in t/11 when there is only one processor. _getNumCpus_from_dmesg_bsd now handles duplicate msgs in dmesg output 1.04 2011-09-29 Tweaks to linux XS code which may or may not reduce mysterious segfaults. 1.03 2011-08-30 Implemented IsWow64 detection in Windows. Using taskset in linux to count CPUs. 1.02 2011-06-17 Removed trivial hello.xs code snippet on the theory that it results in segfaults on linux. 1.01 2011-04-21 XS fixes for FreeBSD. Improved several techniques for counting CPUs. Refactoring of some MSWin32 techniques. 1.00 2011-04-13 Fix for setting affinity of MSWin32 child processes. XS support for NetBSD, get/set affinity of calling process. Untested XS support for Irix with sysmp() library function. Abort CPAN tests on systems with a single processor. 0.99 2010-11-29 Cygwin fix. Can now get num cpus on OpenBSD (thanks, devio.us!) 0.98 2010-10-17 Fix bug finding external programs in OpenBSD. Test improvements. Better use of Win32 XS in Cygwin. Fix compile error and other typos in solaris XS code. 0.97 2010-10-11 Cygwin::pid_to_winpid hack for Perl < v5.10. Disable Win32 GetActiveProcessorCount call, which always either fails quietly or fails noisily. 0.96 2010-05-06 Test fix for solaris. Fix parsing negative which output on some platforms. 0.95 2010-05-04 XS files for Win32. Can call Test::Smoke::SysInfo to detect num cpus. Borrowed code from Test::Smoke::SysInfo for Darwin and Irix. 0.94 2010-04-24 Bug fix in _configExternalProgram's poor man's which. XS support for Windows/Cygwin if Win32::XXX modules aren't available. 0.93 2010-04-21 Fix infinite loop in t/11 for single-processor systems. 0.91 2010-04-20 Removed _configInlineCode calls, will use XS from now on. Bug fix setting affinity for systems with exactly 32 processors. Stub for IRIX support. 0.90 2010-04-11 Initial release Good support for Windows, Cygwin, Linux Basic support for Solaris, FreeBSD, maybe other BSDs Sys-CpuAffinity-1.12/MANIFEST000555034434000144 135113036166656 16417 0ustar00mobrien112general000000000000Build.PL Changes MANIFEST MANIFEST.SKIP Makefile.PL README contrib/contrib.doc contrib/cpusetGetCPUCount.xs contrib/fortytwo.xs contrib/freebsd_cpuset.xs contrib/irix_sysmp.xs contrib/linux-sched_getaffinity.xs contrib/linux-sched_setaffinity.xs contrib/pthread_affinity_np.xs contrib/solaris_processor_affinity.xs contrib/solaris_processor_bind.xs contrib/win32_processaffinity.xs contrib/win32_system_info.xs contrib/win32_system_info_alt.xs contrib/win32_threadaffinity.xs contrib/ok/foo # placeholder for contrib/ok dir contrib/fail/foo # placeholder for contrib/fail dir lib/xs/foo # placeholder for lib/xs dir lib/Sys/CpuAffinity.pm t/00-load.t t/02-available.t t/10-exercise.t t/11-exercise-all.t t/12-32cpus.t META.yml META.json Sys-CpuAffinity-1.12/MANIFEST.SKIP000444034434000144 242213036166657 17162 0ustar00mobrien112general000000000000 #!start included ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ \..*\.sw.?$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid prove files \B\.prove$ # Avoid MYMETA files ^MYMETA\. #!end included ExtUtils/MANIFEST.SKIP # Avoid configuration metadata file ^MYMETA\. # Avoid Module::Build generated and utility files. \bBuild$ \bBuild.bat$ \b_build \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ ^MANIFEST\.SKIP # Avoid archives of this distribution \bSys-CpuAffinity-[\d\.\_]+ # files generated for XS build lib/Sys/CpuAffinity.c lib/Sys/CpuAffinity.o lib/Sys/CpuAffinity.xs Sys-CpuAffinity-1.12/META.yml000444034434000144 137613036166657 16544 0ustar00mobrien112general000000000000--- abstract: 'Set CPU affinity for processes' author: - "Marty O'Brien " build_requires: Module::Build: '0.25' Test::More: '0' configure_requires: Module::Build: '0.25' dynamic_config: 1 generated_by: 'Module::Build version 0.4214, CPAN::Meta::Converter version 2.150005' keywords: - affinity license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Sys-CpuAffinity provides: Sys::CpuAffinity: file: lib/Sys/CpuAffinity.pm version: '1.12' recommends: ExtUtils::CBuilder: '0.15' resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-CpuAffinity license: http://dev.perl.org/licenses/ version: '1.12' x_serialization_backend: 'CPAN::Meta::YAML version 0.016' Sys-CpuAffinity-1.12/META.json000444034434000144 231013036166657 16701 0ustar00mobrien112general000000000000{ "abstract" : "Set CPU affinity for processes", "author" : [ "Marty O'Brien " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4214", "keywords" : [ "affinity" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Sys-CpuAffinity", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.25", "Test::More" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.25" } }, "runtime" : { "recommends" : { "ExtUtils::CBuilder" : "0.15" } } }, "provides" : { "Sys::CpuAffinity" : { "file" : "lib/Sys/CpuAffinity.pm", "version" : "1.12" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-CpuAffinity" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "1.12", "x_serialization_backend" : "JSON::PP version 2.27400" } Sys-CpuAffinity-1.12/README000444034434000144 601613036166657 16147 0ustar00mobrien112general000000000000Sys-CpuAffinity v1.12 ===================== The Sys::CpuAffinity module seeks to "do one thing and do it well": set CPU affinities for processes on any system that can use Perl and by any means necessary. The module is composed of several subroutines, each one implementing a different technique to perform a CPU affinity operation. A technique might try to import a Perl module, run an external program that might be installed on your system, or invoke some C code to access your system libraries. Usually, a technique is applicable to only a single or small group of operating systems, and on any particular system, the vast majority of techniques would fail. Regardless of your particular system and configuration, it is hoped that at least one of the techniques will work and you will be able to get and set the CPU affinities of your processes. SUPPORTED SYSTEMS The techniques for manipulating CPU affinities for Windows (including Cygwin) and Linux have been refined and tested pretty well. Some techniques applicable to BSD systems (particularly FreeBSD) and Solaris have been tested a little bit. The hope is that this module will include more techniques for more systems in future releases. See the NOTE TO DEVELOPERS in the module's POD for information about how you can help. MacOS and OpenBSD are explicitly not supported, as there does not appear to be any public interface for specifying the CPU affinity of a process directly on these platforms. NetBSD support is very limited. The getAffinity and setAffinity calls will only work on the calling process, and will probably only work for the super-user. RECOMMENDED MODULES The following modules are not required by Sys::CpuAffinity, but Sys::CpuAffinity will try to use them if they are available. Win32::API, Win32::Process [MSWin32, cygwin] BSD::Process::Affinity [FreeBSD] INSTALLATION To install this module, the Module::Build module must be installed on your system. Then you may run the following commands: perl Build.PL ./Build ./Build test ./Build install If you need to rebuild the module, or install it for several different version of Perl, it is recommended that you also "./Build clean" before each new installation. SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Sys::CpuAffinity You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-CpuAffinity AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Sys-CpuAffinity CPAN Ratings http://cpanratings.perl.org/d/Sys-CpuAffinity Search CPAN http://search.cpan.org/dist/Sys-CpuAffinity/ LICENSE AND COPYRIGHT Copyright (c) 2010-2017, Marty O'Brien This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Sys-CpuAffinity-1.12/Makefile.PL000444034434000144 236013036166657 17237 0ustar00mobrien112general000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4214 unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); CPAN::Shell->install('Module::Build::Compat'); CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; use lib '_build/lib'; Module::Build::Compat->run_build_pl(args => \@ARGV); my $build_script = 'Build'; $build_script .= '.com' if $^O eq 'VMS'; exit(0) unless(-e $build_script); # cpantesters convention require Sys::CpuAffinity::Custom::Builder; Module::Build::Compat->write_makefile(build_class => 'Sys::CpuAffinity::Custom::Builder'); Sys-CpuAffinity-1.12/Build.PL000444034434000144 2127413036166657 16606 0ustar00mobrien112general000000000000use strict; use warnings; use Module::Build 0.25; use Module::Build::ConfigData; use Carp; if ($ENV{AUTOMATED_TESTING} && !$ENV{BUILD_EVEN_IF_AUTOMATED_TESTING}) { # in general, it should be OK to install this distribution on # a single-processor system. However many of the tests are # either skipped or dumbed down for single-processor systems, # and the resulting PASS reports from the CPAN testers are # not so valuable. # Some systems may require the XS code to be built before the # number of processors can be detected (Irix is like that), # so this gate check won't always work. use Config; my $status = system($Config{perlpath}, "-Ilib", "-MSys::CpuAffinity", "-e", "exit Sys::CpuAffinity::getNumCpus()"); if ($status >> 8 == 1) { print STDERR <<"___"; Single processor system with automated smoke testing detected. Aborting build because many tests in this distribution are skipped or dumbed down for single-processor systems, and the resulting PASS reports from the CPAN testers are not as helpful. Set \$ENV{AUTOMATED_TESTING} to a false value OR \$ENV{BUILD_EVEN_IF_AUTOMATED_TESTING} to a true value if you really wish to build and install this module as opposed to just testing it. ___ ; # a CPAN tester hack to get an NA report # instead of a FAIL report die "No support for OS - one processor and automated testing"; } } # some platform specific notes ... print "\n"; if ($^O =~ /aix/i) { print <<""; $^O users: this platform's bindprocessor(1) utility and bindprocessor(2) library function only allow a process to be bound to a single CPU. Calls to &Sys::CpuAffinity::setAffinity that specify more than one but fewer than all processors might have the effect of only binding the process to a single processor. ; #'; } if ($^O =~ /irix/i) { print <<""; $^O users: this platform generally only allows a process to be bound to a single CPU. Calls to &Sys::CpuAffinity::setAffinity that specify more than one processor might only bind the process to a single processor. Also note that the XS functions in this distribution for $^O may be, ahem, under-tested. ; } if ($^O =~ /netbsd/i) { print <<""; $^O users: the Sys::CpuAffinity::getAffinity and setAffinity methods on this platform generally * can only get/set the CPU affinity of the calling process * can only be used by the super-user ; } print "\n"; if ($^O =~ /darwin|MacOS|openbsd/i) { print <<""; $^O users: no known method to support getting and setting CPU affinity on this platform. You should only expect the Sys::CpuAffinity::getNumCpus function from this distribution to work. ; } unlink "lib/Sys/CpuAffinity.xs"; ############################################################################# my $builderclass = Module::Build->subclass( class => 'Sys::CpuAffinity::Custom::Builder', code => <<'__CUSTOM_BUILD_CODE__,', sub ACTION_build { use File::Copy; my $self = shift; my @successfully_compiled; my $DEBUG = $ENV{DEBUG}; ### STEP 1: Try to compile each .xs file in ./contrib/ ### if (!glob("contrib/fail/*.xs") && ! -f 'lib/Sys/CpuAffinity.xs') { foreach my $contrib_file (glob("contrib/*.xs")) { mkdir 'lib/xs' unless -d 'lib/xs'; my $xs_file = $contrib_file; $xs_file =~ s!contrib!lib/xs!; File::Copy::copy($contrib_file, $xs_file); local $@ = undef; eval { $self->ACTION_code() }; if ($@) { print "\n\nFailed to compile $xs_file\n\n"; print "$@\n" if $DEBUG; File::Copy::move($xs_file, "contrib/fail/"); } else { print "\n\n---------------\nSuccessfully compiled $xs_file\n"; print "---------------\n\n"; push @successfully_compiled, $xs_file; File::Copy::move($xs_file, "contrib/ok/"); } unlink ; } if (@successfully_compiled == 0) { warn q[ None of the XS code snippets successfully compiled. Perhaps you don't have a compiler on your system, or perhaps it is not configured correctly. On some systems and configuration, this module might still work without any XS code, so let's not worry about this just yet. ]; } else { print "======================================\n"; print "Successfully compiled:\n\n\t"; print join "\n\t", @successfully_compiled; print "\n======================================\n"; } } ### STEP 2: Combine contrib/ok/.xs files ### if (glob("contrib/ok/*.xs")) { my (@INCLUDE,%INCLUDE,$MODULE,@PREMOD,@POSTMOD); foreach my $xs (glob("contrib/ok/*.xs")) { open my $xs_fh, '<', $xs; while (<$xs_fh>) { if (m"#include") { next if $INCLUDE{$_}++; push @INCLUDE, $_; } elsif (/^MODULE/) { $MODULE = $_; push @POSTMOD, <$xs_fh>; push @POSTMOD, "\n\n"; } else { push @PREMOD, $_; } } close $xs_fh; print "Incorporating $xs into lib/Sys/CpuAffinity.xs\n"; } print "\n"; unlink ,,'lib/Sys/CpuAffinity.xs'; if (@POSTMOD) { open my $xs_fh, '>', 'lib/Sys/CpuAffinity.xs' or croak $!; print $xs_fh @INCLUDE, @PREMOD, $MODULE, @POSTMOD, "\n\n\n"; close $xs_fh; } } unlink glob("lib/xs/*.xs"), glob("lib/xs/*.o"), glob("lib/xs/*.c"); $self->ACTION_code(); return $self->SUPER::ACTION_build(@_); } sub ACTION_dist { my $self = shift; foreach my $foodir (qw(lib/xs contrib/ok contrib/fail)) { mkdir $foodir unless -d $foodir; open FOO, '>>', "$foodir/foo"; close FOO; } $self->SUPER::ACTION_dist(@_); } __CUSTOM_BUILD_CODE__, ); ############################################################################# mkdir 'lib/xs' unless -d 'lib/xs'; unless (-f 'lib/xs/foo') { my $fooh; open($fooh, '>>', 'lib/xs/foo') && close $fooh; } my $bugtracker_url = 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-CpuAffinity'; my $extra_compiler_flags = ''; my $extra_linker_flags = ''; if ($^O =~ /irix/) { # $extra_linker_flags = '-lcpuset'; } if ($^O =~ /netbsd/i) { $extra_linker_flags = '-lpthread'; } my $recommends = { 'ExtUtils::CBuilder' => 0.15 }; if ($^O =~ /freebsd/i) { $recommends->{'BSD::Process::Affinity'} = 0.04; } if ($^O eq 'MSWin32' || $^O =~ /cygwin/i) { $recommends->{'Win32::API'} = 0.51; } my $builder = $builderclass->new( module_name => 'Sys::CpuAffinity', license => 'perl', dist_author => q[Marty O'Brien ], #dist_version => '1.12', dist_version_from => 'lib/Sys/CpuAffinity.pm', build_requires => { 'Module::Build' => 0.25, 'Test::More' => 0, }, configure_requires => { 'Module::Build' => 0.25, }, recommends => $recommends, meta_merge => { resources => { bugtracker => $bugtracker_url }, keywords => [ qw/affinity/ ], }, add_to_cleanup => [ 'Sys-CpuAffinity-*', '_build', '*.exp', '*.exp_old', '*.xs.o', 'lib/xs/*', 'lib/Sys/CpuAffinity.c', 'lib/Sys/CpuAffinity.o', 'lib/Sys/CpuAffinity.xs', 'contrib/ok/*.xs', 'contrib/fail/*.xs', 'lib*.def', 'ipc.*', 'blib', 'pod2htm*', 'Makefile', 'Build', 'Build.bat', 'perl*.stackdump', 'libcompilet*', ], create_makefile_pl => 'passthrough', extra_compiler_flags => $extra_compiler_flags, extra_linker_flags => $extra_linker_flags, sign => 0, ); $builder->create_build_script(); __END__ The Sys::CpuAffinity module contains several small XS/C functions that target features on many different operating systems. On any particular system, most of the XS files won't compile. So we use a pretty radical build process to find the largest subset of valid XS files for each installation. This file overloads the Module::Build::ACTION_build method with a procedure that: 1) Copies all .xs files from the ./contrib directory into the ./lib/xs/ directory. 2) Calls the Module::Build::ACTION_code method. This will invoke the ExtUtils::CBuilder module to attempt to compile all the .xs files under the lib/ directory. 3) When ACTION_code fails, parse the error message (in $@) to determine which .xs file could not be compiled. Erase that file and repeat step 2. 4) Combine all the remaining valid .xs files into a single .xs file (lib/Sys/CpuAffinity.xs). Erase all traces of the individual .xs units. 5) Call ACTION_code one more time to compile the installation-specific .xs file and continue the build. Sys-CpuAffinity-1.12/t000755034434000144 013036166657 15372 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/t/10-exercise.t000444034434000144 1424413036166656 17765 0ustar00mobrien112general000000000000use Sys::CpuAffinity; use Test::More tests => 14; use Math::BigInt; use strict; use warnings; my $ntests = 14; sub TWO () { goto &Sys::CpuAffinity::TWO } my $n = Sys::CpuAffinity::getNumCpus(); ok($n > 0, "discovered $n processors"); if ($^O =~ /darwin/i || $^O =~ /MacOS/i) { SKIP: { skip "get/set affinity not supported on MacOS", $ntests - 1; } exit 0; } if ($n <= 1) { SKIP: { if ($n == 1) { skip "can't test affinity on single cpu system", $ntests - 1; } else { skip "can't test: can't detect number of cpus", $ntests - 1; } } exit 0; } my $y = Sys::CpuAffinity::getAffinity($$) || 0; ok($y > 0 && $y < TWO**$n, "got current process affinity $y"); my $simpleMask = getSimpleMask($n); my $clearMask = getUnbindMask($n); my $complexMask = getComplexMask($n); # set and clear simple mask (bind to one processor) my $z = Sys::CpuAffinity::setAffinity($$, $simpleMask); ok($z != 0, "simple setCpuAffinity returned non-zero"); my $y1 = Sys::CpuAffinity::getAffinity($$) || 0; ok($y1 == $simpleMask, "setCpuAffinity set affinity to $y1 == $simpleMask != $y"); $z = Sys::CpuAffinity::setAffinity($$, $clearMask); ok($z != 0, "clear simple setCpuAffinity returned non-zero"); my $y2 = Sys::CpuAffinity::getAffinity($$) || 0; # Bizarre - Lucas Nussbaum reports a test where # $y2 == TWO ** $n - 1 is true, but # $y2 + 1 == TWO ** $n is false. # Added some Math::BigInt sanity checks in t/02-available.t but # we'll favor the $y2 == TWO ** $n - 1 check for now ok($y2 == (TWO**$n) - 1, "bind to all processors successful $y2 == ".(TWO**$n)."-1") or do { print STDERR "getAffinity() is $y2, expected ",(TWO**$n)-1,"\n"; print STDERR "comp1 = ",$y2+1 == TWO**$n,"\n"; print STDERR "comp2 = ",$y2 == (TWO**$n)-1,"\n"; }; # set and clear complex mask (more than one processor, but less than all) SKIP: { if ($n < 3) { Sys::CpuAffinity::setAffinity($$, $simpleMask); skip "complex mask test. Need >2 cpus to form complex mask", 2; } if ($^O =~ /aix/) { skip "complex mask test. Processes in $^O may only bind to " . "1 or all processors", 2; } if ($^O =~ /solaris/i && !Sys::CpuAffinity::_is_solarisMultiCpuBinding()) { skip "complex mask test. Processes in this version of $^O may " . "only bind to 1 or all processors", 2; } $z = Sys::CpuAffinity::setAffinity($$, $complexMask); ok($z != 0, "complex setCpuAffinity returned non-zero"); my $y3 = Sys::CpuAffinity::getAffinity($$) || 0; ok($y3 == $complexMask, "setCpuAffinity set affinity to $y3 == " . (sprintf "0x%x", $complexMask) . " != $y2"); } $z = Sys::CpuAffinity::setAffinity($$, -1) or do { local $Sys::CpuAffinity::DEBUG = 1; Sys::CpuAffinity::setAffinity($$, -1); }; ok($z != 0, "setAffinity(-1) returned non-zero"); my $y4 = Sys::CpuAffinity::getAffinity($$) || 0; ok($y4 == (TWO**$n) - 1, "setAffinity(-1) binds to all processors") or do { print STDERR "getAffinity() after setAffinity(-1) is $y4, expected ", (TWO**$n)-1,"\n"; print STDERR "comp1 = ",$y4+1 == TWO**$n,"\n"; print STDERR "comp2 = ",$y4 == (TWO**$n)-1,"\n"; }; { # passing invalid arguments should fail. my $a = Sys::CpuAffinity::getAffinity(173551) || ''; my $b = Sys::CpuAffinity::setAffinity(173551, -1) || ''; my $c = Sys::CpuAffinity::getAffinity(173551) || ''; my $d = Sys::CpuAffinity::setAffinity(-173551, 1) || ''; my $e = Sys::CpuAffinity::getAffinity(-173551) || ''; my $f = Sys::CpuAffinity::setAffinity($$, 0) || ''; my $g = Sys::CpuAffinity::setAffinity($$, TWO ** $n) || ''; ok(!($a||$b||$c||$d||$e||$f||$g), "passing invalid args to getAffinity, setAffinity fails") or diag("$a / $b / $c / $d / $e / $f / $g"); } ################################################################## # On Windows (but not Cygwin), get/set affinity for a child process # is different than for the parent process. my $f = "ipc.$$"; unlink $f; my $pid = CORE::fork(); if (defined($pid) && $pid == 0) { open F, '>', $f; my $y3 = Sys::CpuAffinity::getAffinity($$) || 0; print F "getAffinity:$y3\n"; # solaris can only bind a process to one processor not true anymore # aix can only bind a process to one processor my $r3; if ($^O =~ /aix/i || ($^O =~ /solaris/i && !Sys::CpuAffinity::_is_solarisMultiCpuBinding())) { $r3 = getSimpleMask($n); } else { $r3 = getComplexMask($n); } print F "targetAffinity:$r3\n"; my $z3 = Sys::CpuAffinity::setAffinity($$, $r3); print F "setAffinity:$z3\n"; my $y4 = Sys::CpuAffinity::getAffinity($$) || 0; print F "getAffinity2:$y4\n"; close F; sleep 1; exit 0; } CORE::wait; sleep 1; if ($ENV{DEBUG}) { open F, '<', $f; print ; close F; } open F, '<', $f; my $g = ; my ($y3) = $g =~ /getAffinity:(\d+)/; ok(defined($y3) && $y3 > 0 && $y3 < (TWO**$n), "got pseudo-proc affinity $y3") or diag("\$y3=$y3, child output [1] was: $g"); $g = ; my ($r3) = $g =~ /targetAffinity:(\d+)/; $g = ; my ($z3) = $g =~ /setAffinity:(\d+)/; ok(defined($r3) && defined($z3) && $z3 != 0, "set pseudo-proc affinity non-zero result $z3") or diag(defined($r3),"/",defined($z3),"/<",$z3, ">!=0,\nchild output [2] was $g"); $g = ; close F; unlink $f; ($y4) = $g =~ /getAffinity2:(\d+)/; ok(defined($y4) && $y4 == $r3, "set pseudo-proc affinity to $r3 == $y4 != $y3") or diag(defined($y4),"/<$y4>==$r3\n", "child output [3] was $g"); ################################################################## sub getSimpleMask { my $n = shift; my $r = int(rand() * $n); return TWO ** $r; } sub getComplexMask { my $n = shift; if ($n < 3) { return getSimpleMask($n); } my $s = TWO ** $n; my $r; do { $r = Math::BigInt->new(1) + int(rand($s - 2)); } while ( $r == 0 # don't want no bits set || ($r & ($r-1)) == 0 # don't want one bit set || ($r+1) == $s ); # don't want all bits set return $r; } sub getUnbindMask { my $n = shift; return TWO ** $n - 1; } Sys-CpuAffinity-1.12/t/11-exercise-all.t000444034434000144 2033613036166656 20533 0ustar00mobrien112general000000000000use lib qw(blib/lib blib/arch); use Sys::CpuAffinity; use Test::More tests => 2; use Math::BigInt; use strict qw(vars subs); use warnings; $| = 1; sub TWO () { goto &Sys::CpuAffinity::TWO } # # Exercise all of the methods in the toolbox to # count processors on the system, get cpu affinity, # and set cpu affinity. # # Generally each tool is targeted to work on a # single system. Since most of the tools are # targeted at a different system than yours, # most of these tools will fail on your system. # # Among the tools that are targeted to your # system, some of them will depend on certain # Perl modules or certain external programs # being available, so those tools might also # fail on your system. # # Hopefully, we'll find at least one tool for # each task (count cpus, get affinity, set # affinity) that will work for you, which is # all we need. # my $pid = $$; $Sys::CpuAffinity::IS_TEST = 1; ######################################################### # # get inventory of all Sys::CpuAffinity techniques # from the Sys::CpuAffinity source code. # # XXX - could also inspect %Sys::CpuAffinity:: symbol table. # ######################################################### { my (@SET, @GET, @NCPUS); open my $source, '<', $INC{"Sys/CpuAffinity.pm"} or die "failed to load Sys::CpuAffinity source. $!\n"; while (<$source>) { next unless /^sub _/; next if /XXX/; # method still under development if (/^sub _setAffinity_with_(\S+)/) { push @SET, $1; } elsif (/^sub _getAffinity_with_(\S+)/) { push @GET, $1; } elsif (/^sub _getNumCpus_from_(\S+)/) { push @NCPUS, $1; } } close $source; sub inventory::getAffinity { sort { lc $a cmp lc $b } @GET } sub inventory::setAffinity { sort { lc $a cmp lc $b } @SET } sub inventory::getNumCpus { sort { lc $a cmp lc $b } @NCPUS } } select STDERR; print "\n\n"; EXERCISE_COUNT_NCPUS(); my $n = Sys::CpuAffinity::getNumCpus(); if ($n <= 1) { SKIP: { if ($n == 1) { skip "affinity exercise. Only one processor on this system", 2; } else { skip "affinity exercise. Can't detect number of processors", 2; } } exit 0; } EXERCISE_GET_AFFINITY(); EXERCISE_SET_AFFINITY(); sleep 1; ok(1); # call all of the getAffinity_with_XXX methods # method is successful if # at least one method returns > 0 # all methods that return > 0 return the same value sub EXERCISE_GET_AFFINITY { my $ok = 0; print "===============================================\n"; print "Current affinity = \n"; my $success = 0; for my $s (inventory::getAffinity()) { my $sub = 'Sys::CpuAffinity::_getAffinity_with_' . $s; printf " %-30s ==> ", $s; my $z = eval { $sub->($pid) }; printf "%s\n", $z || 0; $success += ($z||0) > 0; if ($z && $z > 0) { if ($ok == 0) { $ok = $z; } elsif ($ok != $z) { $ok = -1; } } } if ($success == 0) { recommend($^O, 'getAffinity'); } print "\n\n"; SKIP: { if ($ok == 0 && $^O =~ /darwin|MacOS|openbsd/i) { skip "getAffinity/setAffinity not expected to be supported on $^O", 1; } ok($ok > 0, "at least one _getAffinity_XXX method works and " . "all other methods are consistent"); } } # # call all of the _getNumCpus_from_XXX functions. # Passes if # at least one methods returns > 0 # all methods that return > 0 return the same value # sub EXERCISE_COUNT_NCPUS { local $Sys::CpuAffinity::DEBUG = $ENV{DEBUG} || 0; if ($^O =~ /openbsd/i || $^O =~ /darwin/i) { $Sys::CpuAffinity::DEBUG = 1; } print "=================================================\n"; print "Num processors =\n"; my $ok = 0; for my $technique (inventory::getNumCpus()) { my $s = 'Sys::CpuAffinity::_getNumCpus_from_' . $technique; printf " %-30s ", $technique; my $ncpus = eval { $s->() } || 0; printf "- %s -\n", $ncpus; if ($ncpus > 0) { if ($ok eq 0) { $ok = $ncpus; } elsif ($ok ne $ncpus) { $ok = -1; } } } print "\n\n"; # ok($ok > 0, "at least one _getNumCpus_XXX method works and " # . "all other methods are consistent"); } # # call each of the _setAffinity_with_XXX methods. # passes if at least one method works # sub EXERCISE_SET_AFFINITY { print "==================================================\n"; my $np = Sys::CpuAffinity::getNumCpus(); if ($np <= 1) { SKIP: { # skip "skip set affinity test on single-processor sys", 1; 1; } return 0; } my $ok = 0; my ($TARGET,$LAST_TARGET) = (0,0); my @mask = (); my $_2_np_1 = TWO ** $np - 1; my $nc = $np > 10 ? 10 : $np; while (@mask < 100) { $TARGET = 0; for my $i (0 .. @mask) { my $c = int(rand() * $np); $TARGET ^= TWO ** $c; } redo if $TARGET == 0; redo if $TARGET == $LAST_TARGET && $np > 1; $LAST_TARGET = $TARGET; push @mask, $TARGET; } # print "@mask\n"; my $success = 0; print "Set affinity =\n"; for my $technique (inventory::setAffinity()) { my $rr = Sys::CpuAffinity::getAffinity($pid) || 0; if ($rr == 0) { printf " %-30s => %s ==> FAIL\n", $technique, "no affinity"; next; } my $mask; do { $mask = shift @mask; } while $mask == $rr; my $s = "Sys::CpuAffinity::_setAffinity_with_$technique"; eval { $s->($pid,$mask) }; printf " %-30s => %3s ==> ", $technique, $mask; my $r = Sys::CpuAffinity::getAffinity($pid); my $result = $r==$rr ? "FAIL" : " ok "; if ($r != $rr) { $success++; } printf "%3s [%s]\n", $r, $result; } if ($success == 0) { recommend($^O, 'setAffinity'); } print "\n\n"; # ok($success != 0, "at least one _setAffinity_XXX method works"); } sub recommend { use Config; my ($sys, $function) = @_; print "\n\n==========================================\n\n"; print "The function 'Sys::CpuAffinity::$function' does\n"; print "not seem to work on this system.\n\n"; my @recommendations; if ($Config{"cc"}) { @recommendations = ("install a C compiler (preferrably $Config{cc})"); } else { @recommendations = ("install a C compiler"); } if ($sys eq 'cygwin') { push @recommendations, "install the Win32 module"; push @recommendations, "install the Win32::API module"; push @recommendations, "install the Win32::Process module"; } elsif ($sys eq 'MSWin32') { push @recommendations, "install the Win32 module"; push @recommendations, "install the Win32::API module"; push @recommendations, "install the Win32::Process module"; } elsif ($sys =~ /openbsd/i) { @recommendations = (); print "OpenBSD does not provide (as far as I can tell)\n"; print "a way to manipulate the CPU affinities of processes.\n"; print "\n\n==========================================\n\n\n"; return; } elsif ($sys =~ /netbsd/i) { if ($> != 0) { push @recommendations, "run as super-user"; push @recommendations, "\t(the available methods for manipulating CPU affinities " . "on NetBSD only work for super-user)"; } } elsif ($sys =~ /freebsd/i) { push @recommendations, "install the BSD::Process::Affinity module"; push @recommendations, "make sure the cpuset program is in the PATH"; } elsif ($sys =~ /solaris/i) { push @recommendations, "make sure the pbind program is in the PATH"; } elsif ($sys =~ /irix/i) { # still need to learn to use the cpuset_XXX functions } elsif ($sys =~ /darwin/i || $sys =~ /MacOS/i) { @recommendations = (); print "The Mac OS does not provide (as far as I can tell)\n"; print "a way to manipulate the CPU affinities of processes.\n"; print "\n\n==========================================\n\n\n"; return; } elsif ($sys =~ /aix/i) { push @recommendations, "make sure the bindprocessor program is in the PATH"; } else { push @recommendations, "don't know what else to recommend for system $sys"; } if (@recommendations > 0) { print "To make this module work, you may want to install:\n\n"; foreach (@recommendations) { print "\t$_\n"; } print "\n\n"; print "If these recommendations do not help, drop a note\n"; print "to mob\@cpan.org with details about your\n"; print "system configuration.\n"; } print "\n\n==========================================\n\n\n"; } Sys-CpuAffinity-1.12/t/02-available.t000444034434000144 551113036166657 20055 0ustar00mobrien112general000000000000use Sys::CpuAffinity; use Test::More tests => 1; use strict; use warnings; # output the relevant configuration of this system. # when test t/10-exercise.t doesn't pass, # this information is helpful in discovering why print STDERR "\n\nSystem configuration\n====================\n"; print STDERR "\$^O = $^O; \$] = $]\n"; print STDERR "\$ENV{AUTOMATED_TESTING} = ",$ENV{AUTOMATED_TESTING}||'',"\n"; my @xs = grep { eval "defined &Sys::CpuAffinity::$_" } grep { /^xs/ } keys %Sys::CpuAffinity::; if (@xs) { print STDERR "Defined XS functions:\n\t"; print STDERR join "\n\t", sort @xs; print STDERR "\n\n"; } foreach my $module (qw(Win32::API Win32::Process BSD::Process::Affinity Math::BigInt)) { my $avail = Sys::CpuAffinity::_configModule($module); if ($avail) { no warnings 'uninitialized'; $avail .= " v" . eval "\$$module" . "::VERSION"; } print STDERR "module $module: ", ($avail || "not"), " available\n"; } foreach my $externalProgram (qw(bindprocessor dmesg sysctl psrinfo hinv hwprefs lsdev system_profiler prtconf taskset pbind cpuset)) { my $path = Sys::CpuAffinity::_configExternalProgram($externalProgram); if ($path) { print STDERR "$externalProgram available at: $path\n"; } else { print STDERR "$externalProgram: not found\n"; } } print STDERR "\n"; # RT#118730 now appears to be an issue with Math::BigInt? # Let's perform some sanity checks. print STDERR "Math::BigInt sanity checks\n"; print STDERR "==========================\n"; if ($INC{"Math/BigInt.pm"}) { print STDERR "Version $Math::BigInt::VERSION\n"; my $TWO = Math::BigInt->new(2); my $y1 = Math::BigInt->new("18446744073709551616"); my $z1 = Math::BigInt->new("18446744073709551615"); my $y2 = $TWO ** 64; my $z2 = Math::BigInt->new(0); $z2 |= $TWO ** $_ for 0 .. 63; my $y3 = $TWO; $y3->bpow(64); my $z3 = Math::BigInt->new(0); for (0 .. 63) { my $x3 = Math::BigInt->new(2); $x3->bpow($_); $z3 += $x3; } my $checkA1 = ($y1 - 1 == $z1); my $checkB1 = ($y1 == $z1 + 1); my $checkA2 = ($y2 - 1 == $z2); my $checkB2 = ($y2 == $z2 + 1); my $checkA3 = ($y3 - 1 == $z3); my $checkB3 = ($y3 == $z3 + 1); print STDERR " Check 1: $checkA1/$checkB1\n"; print STDERR " Check 2: $checkA2/$checkB2\n"; print STDERR " Check 3: $checkA3/$checkB3\n"; no warnings 'uninitialized'; if ($checkA1 + $checkA2 + $checkA3 + $checkB1 + $checkB2 + $checkB3 != 6) { print STDERR "Issue found\n"; print STDERR " \$y1=$y1, \$z1=$z1\n"; print STDERR " \$y2=$y2, \$z2=$z2\n"; print STDERR " \$y3=$y3, \$z3=$z3\n"; } else { print STDERR "No issue found\n"; } } else { print STDERR "Math::BigInt is not available\n"; } print STDERR "\n"; ok(1); Sys-CpuAffinity-1.12/t/12-32cpus.t000444034434000144 323513036166657 17256 0ustar00mobrien112general000000000000use Sys::CpuAffinity; use Test::More tests => 6; use Math::BigInt; use strict; use warnings; sub TWO () { goto &Sys::CpuAffinity::TWO } my $ncpus = Sys::CpuAffinity::getNumCpus(); if ($ncpus <= 1) { SKIP: { skip "can't test affinity on single cpu system", 6; } exit 0; } if ($^O =~ /darwin/i || $^O =~ /MacOS/i) { SKIP: { skip "test affinity on MacOS not supported", 6; } exit 0; } my $mask = getSimpleMask($ncpus); my $clear1 = getUnbindMask($ncpus); my $clear2 = -1; my $clear = $^O =~ /solaris|irix/i ? $clear2 : $clear1; if ($ncpus < 32) { no warnings 'redefine'; *Sys::CpuAffinity::getNumCpus = sub { return 32 }; diag "This system has $ncpus cpus. ", "Spoofing Sys::CpuAffinity::getNumCpus() to return 32\n"; } else { diag "This system actually has $ncpus cpus.\n"; } my $n = Sys::CpuAffinity::getNumCpus(); ok($n >= 32, "getNumCpus() returns $n>=32 (possibly after redefine)"); my $y0 = Sys::CpuAffinity::getAffinity($$) || 0; if ($^O =~ /solaris/i) { $y0 &= $clear1; } ok($y0 > 0 && $y0 <= $clear1, "got affinity $y0"); my $z1 = Sys::CpuAffinity::setAffinity($$, $mask); ok($z1 != 0, "set affinity ok on 32-cpu system $z1 != 0"); my $y1 = Sys::CpuAffinity::getAffinity($$) || 0; ok($y1 == $mask, "got affinity $y1 == $mask"); my $z2 = Sys::CpuAffinity::setAffinity($$, $clear); ok($z2 != 0, "clear affinity probably ok on 32-cpu system $z2 != 0"); my $y2 = Sys::CpuAffinity::getAffinity($$) || 0; if ($^O =~ /solaris/i) { $y2 &= $clear1; } ok($y2 == $clear1, "got affinity $y2 == $clear1"); sub getSimpleMask { my $n = shift; my $r = int(rand() * $n); return TWO ** $r; } sub getUnbindMask { my $n = shift; return TWO ** $n - 1; } Sys-CpuAffinity-1.12/t/00-load.t000444034434000144 31513036166657 17027 0ustar00mobrien112general000000000000#!perl -T use Test::More tests => 1; eval "alarm 10"; BEGIN { use_ok( 'Sys::CpuAffinity' ) || print "Bail out!\n"; } diag("Testing Sys::CpuAffinity $Sys::CpuAffinity::VERSION, Perl $], $^X, $^O"); Sys-CpuAffinity-1.12/contrib000755034434000144 013036166657 16567 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/contrib/irix_sysmp.xs000444034434000144 263013036166656 21506 0ustar00mobrien112general000000000000#include #include #include #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_irix_sysmp_setaffinity(pid,cpu) int pid int cpu CODE: /* * IRIX allows us to instruct a process to run on a single specific CPU, * or to allow it to run on any CPU. * * The cpu argument should be a value between 0 and numCpus-1 to * choose a single processor to run it on, or -1 to run * on all processors. * * New and untested code as of v1.00 */ int error; int result = 0; if (cpu == -1) { error = sysmp(MP_RUNANYWHERE_PID, pid); if (error) { fprintf(stderr, "sysmp(MP_RUNANYWHERE_PID,%d) error: %d\n", pid, error); result = 0; } else { result = 1; } } else { error = sysmp(MP_MUSTRUN_PID, pid, cpu); if (error) { fprintf(stderr, "sysmp(MP_MUSTRUN_PID,%d,%d) error: %d\n", pid, cpu, error); result = 0; } else { result = 1; } } RETVAL = result; OUTPUT: RETVAL int xs_irix_sysmp_getaffinity(pid) int pid CODE: int result = 0; result = sysmp(MP_GETMUSTRUN_PID, pid); if (result == -1) { if (errno != EINVAL) { fprintf(stderr, "sysmp(MP_GETMUSTRUN_PID,%d) error: %d %s\n", errno, strerror(errno)); result = -2; } else { /* process can run on any processor. */ } } RETVAL = result; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/pthread_affinity_np.xs000444034434000144 556013036166656 23322 0ustar00mobrien112general000000000000#include #include #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_pthread_self_getaffinity(dummy) int dummy CODE: /* * Retrieves the CPU affinity of the current thread. * For use with NetBSD, but it also might work on Linux and FreeBSD. * On NetBSD, may require super-user. * * Return < 0 on error. * Return current thread affinity on success. */ #ifndef DEBIAN /* Ubuntu 15.10 build log filter will abort on the implicit * * int-to-pointer conversion below, even though this xs file * * won't compile -- hide all this code under Debian * * -- http://aunchpadlibrarian.net/222688017 * /buildlog_ubuntu-wily-amd64.libsys-cpuaffinity-perl_1.06-1ubuntu1~wily1_BUILDING.txt.gz */ cpuset_t *cset; pthread_t pth; cpuid_t icpu; int error, affinity; pth = pthread_self(); affinity = 0; cset = cpuset_create(); if (cset == NULL) { fprintf(stderr, "pthread_getaffinity_np: failed to create cpuset\n"); affinity = -1; } error = pthread_getaffinity_np(pth, cpuset_size(cset), cset); if (error) { fprintf(stderr, "pthread_getaffinity_np: %d %s\n", error, strerror(error)); affinity = -1; } if (affinity >= 0) { for (icpu = 0; icpu < 8 * cpuset_size(cset); icpu++) { int n = cpuset_isset(icpu, cset); if (n < 0) { break; } else if (n > 0) { affinity |= 1 << icpu; } } /* * What does it mean if affinity is still 0 here? * Does that mean that pthread_getaffinity_np didn't work? * Or does it mean that the thread affinity is in a default * (i.e., affinitied to all processors)? */ } if (cset != NULL) { cpuset_destroy(cset); } #endif RETVAL = affinity; OUTPUT: RETVAL int xs_pthread_self_setaffinity(affinity) int affinity CODE: /* * Sets the CPU affinity for the current thread. * For use with NetBSD. Might need to be run as super-user. * Returns 0 on error, 1 on success. */ #ifndef DEBIAN cpuset_t *cset; pthread_t pth; cpuid_t icpu; int error, result; pth = pthread_self(); result = 2; cset = cpuset_create(); if (cset == NULL) { fprintf(stderr, "xs_set_pthread_self_affinity: failed to create cpu set\n"); result = 0; } else { for (icpu = 0; icpu < 8 * cpuset_size(cset); icpu++) { if (affinity & (1 << icpu)) { cpuset_set(icpu, cset); } else { cpuset_clr(icpu, cset); } } error = pthread_setaffinity_np(pth, cpuset_size(cset), cset); if (error) { fprintf(stderr, "xs_set_pthread_self_affinity: %d %s\n", error, strerror(error)); result = 0; } else { result = 1; } } if (cset != NULL) { cpuset_destroy(cset); } #endif RETVAL = result; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/win32_processaffinity.xs000444034434000144 414613036166657 23537 0ustar00mobrien112general000000000000#include #include #include #include #include #if (_WIN32_WINNT < 0x0500) && (_WIN32_WINDOWS < 0x0490) WINBASEAPI HANDLE WINAPI OpenThread(DWORD,BOOL,DWORD); #endif int win32_set_process_affinity(DWORD process_id, DWORD mask) { HANDLE handle; BOOL result1; if (process_id <= 0) { process_id = GetCurrentProcessId(); } handle = OpenProcess(0x0600, 0, process_id); #ifdef DEBUG fprintf(stderr, "win32_set_process_affinity(%d,%d) called\n", process_id, mask); fprintf(stderr, "HANDLE(%d) IS %d.\n", (int) process_id, (int) handle); #endif if (handle == NULL) { return 0; } result1 = SetProcessAffinityMask(handle, mask); #ifdef DEBUG if (result1 == 0) { fprintf(stderr, "win32_set_process_affinity: Error %d\n", GetLastError()); } fprintf(stderr,"SetProcessAffinityMask(%d,0x%x) => %d\n", (int) handle, mask, (int) result1); #endif CloseHandle(handle); return (int) result1; } int win32_get_process_affinity(DWORD process_id) { DWORD_PTR procMask = 0; DWORD_PTR sysMask = 0; HANDLE handle; BOOL result1; if (process_id <= 0) { process_id = GetCurrentProcessId(); } handle = OpenProcess(0x0400, 0, process_id); if (handle == NULL) { handle = OpenProcess(0x1000, 0, process_id); } if (handle == NULL) { return 0; } result1 = GetProcessAffinityMask(handle, &procMask, &sysMask); #ifdef DEBUG fprintf(stderr, "win32_get_process_affinity(%d) called\n", process_id); fprintf(stderr, "HANDLE (%d) IS %d\n", (int) process_id, (int) handle); fprintf(stderr, "GetProcessAffinityMask(%d) => %d %d: %d\n", handle, procMask, sysMask, (int) result1); if (result1 == 0) { fprintf(stderr, "win32_get_process_affinity: %d\n", GetLastError()); } #endif CloseHandle(handle); return (int) procMask; } MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_win32_getAffinity_proc(pid) int pid CODE: RETVAL = win32_get_process_affinity(pid); OUTPUT: RETVAL int xs_win32_setAffinity_proc(pid,mask) int pid int mask CODE: RETVAL = win32_set_process_affinity(pid,mask); OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/win32_system_info_alt.xs000444034434000144 224113036166657 23520 0ustar00mobrien112general000000000000#include #include #include #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity #pragma comment(lib, "user32.lib") void xs_display_system_info_alt() CODE: SYSTEM_INFO siSysInfo; // Copy the hardware information to the SYSTEM_INFO structure. GetSystemInfo(&siSysInfo); // Display the contents of the SYSTEM_INFO structure. printf("Hardware information: \n"); printf(" OEM ID: %u\n", siSysInfo.dwOemId); printf(" Number of processors: %u\n", siSysInfo.dwNumberOfProcessors); printf(" Page size: %u\n", siSysInfo.dwPageSize); printf(" Processor type: %u\n", siSysInfo.dwProcessorType); printf(" Minimum application address: %lx\n", siSysInfo.lpMinimumApplicationAddress); printf(" Maximum application address: %lx\n", siSysInfo.lpMaximumApplicationAddress); printf(" Active processor mask: %u\n", siSysInfo.dwActiveProcessorMask); int xs_get_numcpus_from_windows_system_info_alt() CODE: SYSTEM_INFO siSysInfo; GetSystemInfo(&siSysInfo); RETVAL = siSysInfo.dwNumberOfProcessors; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/contrib.doc000444034434000144 752113036166657 21060 0ustar00mobrien112general000000000000 XS files for Sys::CpuAffinity module. ------------------------------------- During build, these *.xs files are copied to the ./lib directory structure, where ExtUtils::CBuilder will attempt to compile them. Any units that fail to compile will be removed from the ./lib directory tree. The remaining units that successfully compiled will be removed and combined into a single lib/Sys/CpuAffinity.xs file. Additional contributions to this directory should follow these guidelines: * Exported functions should go under the "Sys::CpuAffinity" module and "Sys::CpuAffinity" package unless there is a compelling reason to use something else. * The names of all exported functions (listed below the file's "MODULE = Sys::CpuAffinity ..." line) should begin with "xs_". The test script t/02-available.t will try to categorize all the available XS functions that follow these first two conventions. * ALL function names should be unique across all files in /contrib -- don't rely on any pair of files in this directory being mutually uncompilable. * Files need to end with one or more blank lines, or else the aggregated lib/Sys/CpuAffinity.xs might not compile. ======================================================= cpusetGetCpuCount.xs Function to count the CPUs on on Irix system. cpuset_getaffinity.xs cpuset_setaffinity.xs Functions to manipulate affinity. Should work for FreeBSD >= 7.1. Requires , , and headers. irix_sysmp.xs Use the sysmp() in Irix to bind a process to a SINGLE processor (like the processor_bind() restriction in Solaris). Requires and headers. linux-sched_get_affinity.xs linux-sched_set_affinity.xs Get and set process affinity in Linux. Requires the and headers. pthread_affinity_np.xs Uses pthread_getaffinity_np and pthread_setaffinity_np methods available in NetBSD >= 5.0. May also work in FreeBSD and/or Linux. These functions only work on the calling process and may only work for the super-user. Requires and headers, and link with libpthread.a library (-lpthread). solaris_processoraffinity.xs Uses processor_affinity() function on Solaris to perform binding to arbitrary sets of cpus. Available in Solaris 11.2. Requires many system headers. Also see solaris_processorbind.xs solaris_processorbind.xs Use processor_bind() function in Solaris. Can be used to bind a process to a SINGLE cpu. Requires , , and headers. On Solaris >= 11.2 where solaris_processaffinity.xs compiled successfully, the functions in this file will not be used. win32_processaffinity.xs Get and set affinity for a bona-fide process on MSWin32 and Cygwin. Requires and headers. I'm a little bit uncomfortable with some of the hard-coded (magic) numbers. win32_threadaffinity.xs Get and set affinity of a Windows pseudo-process -- the result of a fork() call on MSWin32. Within Perl, pseudo-processes are characterized by a negative process ID. Requires the and headers. win32_system_info.xs Functions to retrieve system info (including the number of processors) on Windows systems (including Cygwin). Uses the and headers. win32_system_info_alt.xs Identical functionality to win32_system_info.xs but looks for the and headers. Uses alternate function names in case both win32_system_info files successfully compile. fortytwo.xs Sample XS files that should compile on any system (or at least any system with a compiler). Even if nothing else compiles, this will give you a CpuAffinity.xs file and demonstrate that XS is available on your system. Sys-CpuAffinity-1.12/contrib/win32_system_info.xs000444034434000144 224713036166657 22666 0ustar00mobrien112general000000000000#include #include #include #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity #pragma comment(lib, "user32.lib") void xs_display_system_info() CODE: SYSTEM_INFO siSysInfo; // Copy the hardware information to the SYSTEM_INFO structure. GetSystemInfo(&siSysInfo); // Display the contents of the SYSTEM_INFO structure. printf("Hardware information: \n"); printf(" OEM ID: %u\n", siSysInfo.dwOemId); printf(" Number of processors: %u\n", siSysInfo.dwNumberOfProcessors); printf(" Page size: %u\n", siSysInfo.dwPageSize); printf(" Processor type: %u\n", siSysInfo.dwProcessorType); printf(" Minimum application address: %lx\n", siSysInfo.lpMinimumApplicationAddress); printf(" Maximum application address: %lx\n", siSysInfo.lpMaximumApplicationAddress); printf(" Active processor mask: %u\n", siSysInfo.dwActiveProcessorMask); int xs_get_numcpus_from_windows_system_info() CODE: SYSTEM_INFO siSysInfo; GetSystemInfo(&siSysInfo); RETVAL = siSysInfo.dwNumberOfProcessors; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/linux-sched_getaffinity.xs000444034434000144 520013036166657 24111 0ustar00mobrien112general000000000000#include #include #include #include #include /* * This declaration isn't used and looks useless. But for some * reason I don't understand at all, for some versions of perl * with some build configurations running on some systems, * this declaration is the difference between XS code that works * (specifically, passing t/11-exercise-all.t) and code that * segfaults. For the same reason, the cpu_set_t variables * in xs_sched_getaffinity_get_affinity() below are declared * static . * * Any insights into this issue would be profoundly appreciated. */ char ___linux_sched_getaffinity_dummy[4096]; void diag() { fprintf(stderr,"---\n"); fprintf(stderr,"diag CPU_SETSIZE=%d\n", CPU_SETSIZE); fprintf(stderr,"diag sizeof(__cpu_mask)=%d\n", (int) sizeof(__cpu_mask)); fprintf(stderr,"diag __NCPUBITS=%d\n", (int) __NCPUBITS); fprintf(stderr,"diag sizeof(cpu_set_t)=%d\n", (int) sizeof(cpu_set_t)); fprintf(stderr,"diag sizeof(pid_t)=%d\n", (int) sizeof(pid_t)); } MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_sched_getaffinity_get_affinity(pid,maskarray,debug_flag) int pid AV *maskarray int debug_flag CODE: int i, z; int r = 0; int ncpus = __NCPUBITS; static cpu_set_t _set2, *_set1; if(debug_flag) diag(); if(debug_flag) fprintf(stderr,"getaffinity0\n"); _set1 = &_set2; if(debug_flag) { fprintf(stderr,"getaffinity1 pid=%d size=%d %d ncpu=%d cpuset=%p\n", (int) pid, (int) CPU_SETSIZE, (int) sizeof(cpu_set_t), ncpus, (void *) _set1); } /* RT 94560: CPU_SETSIZE might be less than sizeof(cpu_set_t) ? */ z = sched_getaffinity((pid_t) pid, sizeof(cpu_set_t), _set1); #ifdef CPU_COUNT ncpus = CPU_COUNT(_set1); #endif if(debug_flag) fprintf(stderr,"getaffinity2 ncpus=%d\n", ncpus); if (z) { if(debug_flag) fprintf(stderr,"getaffinity3 z=%d err=%d\n", z, errno); r = 0; } else { av_clear(maskarray); if(debug_flag) fprintf(stderr,"getaffinity5\n"); /* tests.reproducible-builds.org/debian/rb-pkg/unstable/i386/ libsys-cpuaffinity-perl.html: __NCPUBITS=32 but taskset,/proc/cpuinfo say there are 34 cpus */ for (i = 0, r = 0; i < ncpus; i++) { if(debug_flag) fprintf(stderr,"getaffinity6 i=%d r=%d\n", i, r); if (CPU_ISSET(i, &_set2)) { r |= 1; av_push(maskarray, newSViv(i)); if(debug_flag) fprintf(stderr,"getaffinity8 add %d to mask\n", i); } } if(debug_flag) fprintf(stderr,"getaffinitya r=%d\n",r); } RETVAL = r; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/solaris_processor_affinity.xs000444034434000144 1012313036166657 24761 0ustar00mobrien112general000000000000#include #include #include #include #include #include #include #include #include /* CPU affinity on solaris: Solaris 11.2 allows "Multi-CPU Binding" through the processor_affinity(2) system call. Using it is superior to the pset_XXX suite of functions or the psrset utility, as it typically requires privileges to set up a processor set. processor_bind(2) is a backwards-compatible wrapper around process_affinity() that can bind threads to a single processor, and is available on systems prior to 11.2. processor_affinity usage: int processor_affinity(procset_t *ps, uint_t *nids, id_t *ids, uint32_t *flags) ps: procset structure that identifies which LWPs are affected by the call nids: pointer to size of ids ids: array of processor IDs flags: combo of bit masks: PA_QUERY to query flags and affinities PA_CLEAR to clear existing affinity PA_TYPE_CPU ids is array of processor IDs (default) PA_TYPE_PG ids is array of processor group IDs (not interesting) PA_TYPE_LGRP ids is array of Locality Group IDs (not interesting) PA_AFF_WEAK set weak affinity (preference for CPUs, not interesting) PA_AFF_STRONG set strong affinity (required to run on CPUs) PA_NEGATIVE used with AFF_WEAK/STRONG to *avoid* certain CPUs PA_INH_EXEC affinity should not be inherited across an exec call PA_INH_FORK affinity should not be inherited across a fork call PA_INH_THR affinity should not be inherited by a new thread on a query (PA_QUERY), *nids will be # of processors that PID has affinity for, ids will contain "the IDs of the indicated type", flags will have info about affinity strength and inheritance */ int getaffinity_processor_affinity(int pid,AV *mask) { int r,i; uint_t np = sysconf(_SC_NPROCESSORS_ONLN); uint32_t flags = PA_QUERY | PA_TYPE_CPU; id_t *ids = malloc(sizeof(id_t) * np); uint_t n = np; procset_t ps; setprocset(&ps, POP_AND, P_PID, pid, P_ALL, 0); r = processor_affinity(&ps, &n, ids, &flags); if (r != 0) { /* error */ fprintf(stderr,"xs_getaffinity_processor_affinity: " "processor_affinity() returned %d errno=%d\n", r, errno); return 0; } if (n == 0) { /* unbound */ av_clear(mask); for (i=0; i np) { fprintf(stderr,"xs_setaffinity_processor_affinity: cpu mask is larger " "than num cpus (%d > %d)\n", n, np); return 0; } if (n == 0) { fprintf(stderr,"xs_setaffinity_processor_affinity: no CPU mask specified!"); return 0; } if (n == np) { /* unbind processor */ flags |= PA_CLEAR; r = processor_affinity(&ps, &n, ids, &flags); } else { for (i=0; i #include #include #include #include #if (_WIN32_WINNT < 0x0500) && (_WIN32_WINDOWS < 0x0490) WINBASEAPI HANDLE WINAPI OpenThread(DWORD,BOOL,DWORD); #endif int win32_set_thread_affinity(DWORD thread_id, DWORD mask) { HANDLE handle; DWORD result1, result2; if (thread_id <= 0) { thread_id = GetCurrentThreadId(); } handle = OpenThread(0x0060, 0, thread_id); #ifdef DEBUG fprintf(stderr, "win32_set_thread_affinity(%d,%d) called\n", thread_id, mask); fprintf(stderr, "HANDLE (%d) IS %d.\n", (int) thread_id, (int) handle); #endif if (handle == NULL) { return 0; } result1 = SetThreadAffinityMask(handle, mask); result2 = SetThreadAffinityMask(handle, mask); #ifdef DEBUG fprintf(stderr,"SetThreadAffinityMask(%d,0x%x) => %d %d\n", (int) handle, mask, (int) result1, (int) result2); if (result1 == 0 || result2 == 0) { fprintf(stderr, "win32_set_thread_affinity: Error %d\n", GetLastError()); } #endif CloseHandle(handle); return (int) result1; } int win32_get_thread_affinity(DWORD thread_id) { DWORD mask = 1; HANDLE handle; DWORD result1, result2, result3; if (thread_id <= 0) { thread_id = GetCurrentThreadId(); } handle = OpenThread(0x0040, 0, thread_id); if (handle == NULL) { handle = OpenThread(0x0200, 0, thread_id); } if (handle == NULL) { fprintf(stderr, "could not obtain handle for thread id %d\n", thread_id); return 0; } result1 = SetThreadAffinityMask(handle, mask); result2 = SetThreadAffinityMask(handle, result1); result3 = SetThreadAffinityMask(handle, result1); #ifdef DEBUG fprintf(stderr, "win32_get_thread_affinity(%d) called\n", thread_id); fprintf(stderr, "HANDLE (%d) IS %d\n", (int) thread_id, (int) handle); fprintf(stderr, "SetThreadAffinityMask(%d,[0x%x,0x%x,0x%x]) => 0x%x, 0x%x, 0x%x\n", (int) handle, mask, result1, result1, result1, result2, result3); if (result1 == 0 || result2 == 0 || result3 == 0) { fprintf(stderr, "win32_get_thread_affinity: %d\n", GetLastError()); } if (result3 != result1) { fprintf(stderr, "win32_get_thread_affinity: %d != %d\n", result1, result3); } #endif CloseHandle(handle); return (int) result1; } MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_win32_getAffinity_thread(pid) int pid CODE: RETVAL = win32_get_thread_affinity(pid); OUTPUT: RETVAL int xs_win32_setAffinity_thread(pid,mask) int pid int mask CODE: RETVAL = win32_set_thread_affinity(pid,mask); OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/fortytwo.xs000444034434000144 136513036166657 21202 0ustar00mobrien112general000000000000#include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_fortytwo() CODE: /* The purpose of this trivial code snippet is to see whether you can compile something, anything, during this build process. If this doesn't compile, then you probably don't have a compiler or it is badly misconfigured, and you won't be able to generate any XS code with this distribution. If this is the ONLY thing that compiles, then your system-specific snippets might be incorrect, or your system might be obscure enough that no system-specific snippets have been developed for it yet. */ RETVAL = 42; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/freebsd_cpuset.xs000444034434000144 1110613036166657 22314 0ustar00mobrien112general000000000000#include #include #include #include #include #include #include #include #include int num_cpus_sysctl() { int mib[2], ncpu; size_t len; mib[0] = CTL_HW; mib[1] = HW_NCPU; len = sizeof(ncpu); sysctl(mib, 2, &ncpu, &len, NULL, 0); return ncpu; } int getaffinity_freebsd(int pid, AV *mask, int debug) { cpulevel_t level = CPU_LEVEL_WHICH; cpuwhich_t which = CPU_WHICH_PID; id_t id = (id_t) pid; size_t setsize; cpuset_t cpumask; int i, r; setsize = sizeof(cpumask); if (debug) { fprintf(stderr,"calling cpuset_getaffinity(%d,%d,%d,%d,&cpumask)\n", (int) level, (int) which, (int) id, (int) setsize); } r = cpuset_getaffinity(level, which, id, setsize, &cpumask); if (debug) { fprintf(stderr,"cpuset_getaffinity return value: %d\n", r); } if (r != 0) { if (errno == EINVAL) { fprintf(stderr, "cpuset_getaffinity: invalid level or which arg\n"); } else if (errno == EDEADLK) { fprintf(stderr, "cpuset_getaffinity: EDEADLK encountered\n"); } else if (errno == EFAULT) { fprintf(stderr, "cpuset_getaffinity: EFAULT - invalid cpu mask\n"); } else if (errno == ESRCH) { fprintf(stderr, "cpuset_getaffinity: ESRCH - invalid pid\n"); } else if (errno == ERANGE) { fprintf(stderr, "cpuset_getaffinity: ERANGE - invalid cpusetsize\n"); } else if (errno == EPERM) { fprintf(stderr, "cpuset_getaffinity: EPERM - " "no permission to get affinity for pid=%d\n", pid); } else { fprintf(stderr, "cpuset_getaffinity: unknown error %d\n", errno); } return 0; } else { int ncpu = num_cpus_sysctl(); int nset = 0; if (debug) { fprintf(stderr,"num_cpus_sysctl() returned: %d\n", ncpu); } if (ncpu <= 0) { fprintf(stderr, "getaffinity_freebsd: " "failed to get num cpus from sysctl\n"); ncpu = 32; } for (i = 0; i < ncpu; i++) { if (CPU_ISSET(i, &cpumask)) { nset++; av_push(mask, newSViv(i)); if (debug) { fprintf(stderr,"cpu #%d is set\n", i); } } else if (debug) { fprintf(stderr,"cpu #%d is clear\n", i); } } if (nset == 0) { fprintf(stderr, "getaffinity_freebsd: no cpu set in cpumask\n"); for (i = 0; i < ncpu; i++) { av_push(mask, newSViv(i)); } } return 1; } } int setaffinity_freebsd(int pid, AV *mask) { cpulevel_t level = CPU_LEVEL_WHICH; cpuwhich_t which = CPU_WHICH_PID; id_t id = (id_t) pid; size_t setsize; cpuset_t cpumask; int i, r; int n = av_len(mask) + 1; int ncpu = num_cpus_sysctl(); CPU_ZERO(&cpumask); if (ncpu > 0 && n > ncpu) { fprintf(stderr, "setaffinity_freebsd: " "mask is larger than the number of cpus!\n"); } setsize = sizeof(cpumask); for (i = 0; i < n; i++) { int proc_id = SvIV(*av_fetch(mask, i, 0)); if (ncpu <= 0 || proc_id < ncpu) { CPU_SET(proc_id, &cpumask); } else { fprintf(stderr, "setaffinity_freebsd: ignoring request to set " "processor %d which exceeds known num cpus %d\n", proc_id, ncpu); } } r = cpuset_setaffinity(level, which, id, setsize, &cpumask); if (r != 0) { if (errno == EINVAL) { fprintf(stderr, "cpuset_setaffinity: EINVAL - " "bad level, which, or mask arg\n"); } else if (errno == EDEADLK) { fprintf(stderr, "cpuset_setaffinity: EDEADLK found\n"); } else if (errno == EFAULT) { fprintf(stderr, "cpuset_setaffinity: EFAULT - invalid mask pointer\n"); } else if (errno == ESRCH) { fprintf(stderr, "cpuset_setaffinity: ESRCH - invalid pid\n"); } else if (errno == ERANGE) { fprintf(stderr, "cpuset_setaffinity: ERANGE - bad cpusetsize\n"); } else if (errno == EPERM) { fprintf(stderr, "cpuset_setaffinity: EPERM - " "no permission to set affinity on pid=%d\n", pid); } else { fprintf(stderr, "cpuset_setaffinity: unexpected error no=%d\n", errno); } return 0; } else { return 1; } } MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_getaffinity_freebsd(pid,mask,debug) int pid AV *mask int debug CODE: RETVAL = getaffinity_freebsd(pid,mask,debug); OUTPUT: RETVAL int xs_setaffinity_freebsd(pid,mask) int pid AV *mask CODE: RETVAL = setaffinity_freebsd(pid,mask); OUTPUT: RETVAL int xs_num_cpus_freebsd() CODE: RETVAL = num_cpus_sysctl(); OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/solaris_processor_bind.xs000444034434000144 1026213036166657 24070 0ustar00mobrien112general000000000000#include #include #include #include #include #include #include int setaffinity_processor_unbind(int pid) { int r; r = processor_bind(P_PID, (id_t) pid, PBIND_NONE, NULL); if (r != 0) { if (errno == EFAULT) { fprintf(stderr,"setaffinity_processor_unbind: error code EFAULT\n"); return 0; } else if (errno == EINVAL) { fprintf(stderr,"setaffinity_processor_unbind: error code EINVAL\n"); return 0; } else if (errno == EPERM) { fprintf(stderr,"setaffinity_processor_unbind: no permission to bind %d\n", pid); return 0; } else if (errno == ESRCH) { fprintf(stderr,"setaffinity_processor_unbind: no such PID %d\n", pid); return 0; } else { fprintf(stderr,"setaffinity_processor_unbind: unknown error %d\n", errno); return 0; } } return 1; } int setaffinity_processor_bind(int pid,AV* mask) { int r,z; idtype_t idtype = P_PID; id_t id = (id_t) pid; processorid_t processorid = (processorid_t) mask; processorid_t obind = (processorid_t) mask; int ncpus = sysconf(_SC_NPROCESSORS_ONLN); int len_mask = av_len(mask) + 1; if (len_mask > ncpus) { fprintf(stderr,"setaffinity_processor_bind: too many items in cpu mask!\n"); return 0; } if (len_mask == ncpus || len_mask == 0) { /* unbind */ return setaffinity_processor_unbind(pid); } if (len_mask > 1) { fprintf(stderr,"setaffinity_processor_bind: processor_bind() can only bind a process to a single cpu. Your complete set of desired CPU affinities will not be respected.\n"); } z = SvIV(*av_fetch(mask, 0, 0)); if (z < 0 || z >= ncpus) { fprintf(stderr,"setaffinity_processor_bind: invalid cpu spec %d\n", z); return 0; } r = processor_bind(P_PID, (id_t) pid, (processorid_t) z, NULL); if (r != 0) { if (errno == EFAULT) { fprintf(stderr,"setaffinity_processor_bind: error code EFAULT\n"); return 0; } else if (errno == EINVAL) { fprintf(stderr,"setaffinity_processor_bind: error code EINVAL\n"); return 0; } else if (errno == EPERM) { fprintf(stderr,"setaffinity_processor_bind: no permission to bind %d\n", pid); return 0; } else if (errno == ESRCH) { fprintf(stderr,"setaffinity_processor_bind: no such PID %d\n", pid); return 0; } else { fprintf(stderr,"setaffinity_processor_bind: unknown error %d\n", errno); return 0; } } return 1; } int getaffinity_processor_bind(int pid, AV* mask) { int r,z; processorid_t obind; r = processor_bind(P_PID, (id_t) pid, PBIND_QUERY, &obind); if (r != 0) { if (errno == EFAULT) { fprintf(stderr,"getaffinity_processor_bind: error code EFAULT %d\n",r); return 0; } else if (errno == EINVAL) { fprintf(stderr,"getaffinity_processor_bind: error code EINVAL %d\n",r); return 0; } else if (errno == EPERM) { fprintf(stderr, "getaffinity_processor_bind: no permission to pbind %d (%d)\n", pid, r); return 0; } else if (errno == ESRCH) { fprintf(stderr,"getaffinity_processor_bind: no such PID %d (%d)\n", pid, r); return 0; } else { fprintf(stderr,"getaffinity_processor_bind: unknown error %d %d\n", errno, r); return 0; } } if (obind == PBIND_NONE) { /* process is unboud */ int i, n; n = sysconf(_SC_NPROCESSORS_ONLN); av_clear(mask); for (i=0; i #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_cpusetGetCPUCount() CODE: /* Count the number of CPUs on an Irix system. */ int ncpus = cpusetGetCPUCount(); RETVAL = ncpus; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/linux-sched_setaffinity.xs000444034434000144 333513036166657 24134 0ustar00mobrien112general000000000000#include #include #include #include #include MODULE = Sys::CpuAffinity PACKAGE = Sys::CpuAffinity int xs_sched_setaffinity_set_affinity(pid,mask) int pid AV *mask CODE: static cpu_set_t cpumask; int i,r; CPU_ZERO(&cpumask); for (i=0; i <= av_len(mask); i++) { int c = SvIV(*av_fetch(mask,i,0)); CPU_SET(c, &cpumask); } r = sched_setaffinity(pid, sizeof(cpu_set_t), &cpumask); if (r != 0) { fprintf(stderr,"result: %d %d %s\n", r, errno, errno==EFAULT ? "EFAULT" /* a supplied memory address was invalid */ : errno==EINVAL ? "EINVAL" /* the affinity bitmask contains no processors that are physically on the system, or _cpusetsize_ is smaller than the size of the affinity mask used by the kernel */ : errno==EPERM ? "EPERM" /* the calling process does not have appropriate privilieges. The process calling *sched_setaffinity()* needs an effective user ID equal to the user ID or effective user ID of the process identified by _pid_, or it must possess the _CAP_SYS_NICE_ capability. */ : errno==ESRCH ? "ESRCH" /* the process whose ID is _pid_ could not be found */ :"E_WTF"); } RETVAL = !r; OUTPUT: RETVAL Sys-CpuAffinity-1.12/contrib/fail000755034434000144 013036166657 17502 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/contrib/fail/foo000444034434000144 013036166657 20253 0ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/contrib/ok000755034434000144 013036166657 17200 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/contrib/ok/foo000444034434000144 013036166657 17751 0ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/lib000755034434000144 013036166657 15675 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/lib/Sys000755034434000144 013036166656 16452 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/lib/Sys/CpuAffinity.pm000444034434000144 17400313036166656 21433 0ustar00mobrien112general000000000000package Sys::CpuAffinity; use Math::BigInt; use Carp; use warnings; use strict; use base qw(DynaLoader); use Data::Dumper; ## no critic (ProhibitBacktick,RequireExtendedFormatting) ## no critic (DotMatch,LineBoundary,Sigils,Punctuation,Quotes,Magic,Checked) ## no critic (NamingConventions::Capitalization,BracedFileHandle) our $VERSION = '1.12'; our $DEBUG = $ENV{DEBUG} || 0; our $XS_LOADED = 0; eval { bootstrap Sys::CpuAffinity $VERSION; $XS_LOADED = 1 }; sub TWO () { Math::BigInt->new(2) } # sub import { } # # Development guide: # # when you figure out a new way to perform a task # (in this case, getting cpu affinity), write the method and insert # the call into the chain here. # # Methods should be named _getAffinity_with_XXX, _setAffinity_with_XXX, # or _getNumCpus_from_XXX. The t/inventory.pl file will identify these # methods so they can be included in the tests. # # The new method should return false (0 or '' or undef) whenever it # knows it is the wrong tool for the current system or any other time # that it can't figure out the answer. # # For XS-based solutions, the stub will go in the distributions # contrib/ directory, and will be available if it successfully # compiles during the installation process. See # _getAffinity_with_xs_sched_getaffinity for an example of # how to use a compiled function. All exported XS function names # should begin with "xs_" and all function names, even the ones # that aren't exported to XS, should be unique across the whole # /contrib space. # # Methods that might return with the wrong answer (for example, methods # that make a guess) should go toward the end of the chain. This # probably should include methods that read environment variables # or methods that rely on external commands as these methods are # easier to spoof, even accidentally. # sub getAffinity { my ($pid, %flags) = @_; # %flags reserved for future use my $wpid = $pid; my $mask = 0 || _getAffinity_with_taskset($pid) || _getAffinity_with_xs_sched_getaffinity($pid) || _getAffinity_with_xs_pthread_self_getaffinity($pid) || _getAffinity_with_BSD_Process_Affinity($pid) || _getAffinity_with_xs_freebsd_getaffinity($pid) || _getAffinity_with_cpuset($pid) || _getAffinity_with_xs_processor_affinity($pid) || _getAffinity_with_pbind($pid) || _getAffinity_with_xs_processor_bind($pid) || _getAffinity_with_psaix($pid) || _getAffinity_with_xs_win32($pid) || _getAffinity_with_xs_irix_sysmp($pid) || _getAffinity_with_Win32Process($wpid) || _getAffinity_with_Win32API($wpid) || 0; return if $mask == 0; return wantarray ? _maskToArray($mask) : $mask; } sub _sanitize_set_affinity_args { my ($pid,$mask) = @_; if ($DEBUG) { print STDERR "sanitize_set_affinity_args: input is ",Dumper(@_),"\n"; } return if ! $pid; if (ref $mask eq 'ARRAY') { $mask = _arrayToMask(@$mask); if ($DEBUG) { print STDERR "sanitize_set_affinity_args: ", Dumper($_[1])," => $mask\n"; } } my $np = getNumCpus(); if ($mask == -1 && $np > 0) { $mask = (TWO ** $np) - 1; if ($DEBUG) { print STDERR "sanitize_set_affinity_args: -1 => ", $mask," ",Dumper($mask),"\n"; } } if ($mask <= 0) { carp "Sys::CpuAffinity: invalid mask $mask in call to setAffinty\n"; return; } my $maxmask = TWO ** $np; if ($maxmask > 1 && $mask >= $maxmask) { my $newmask = $mask & ($maxmask - 1); if ($newmask == 0) { carp "Sys::CpuAffinity: mask $mask is not valid for system with ", "$np processors.\n"; return; } else { carp "Sys::CpuAffinity: mask $mask adjusted to $newmask for ", "system with $np processors\n"; $mask = $newmask; } } $_[1] = $mask; return 1; } sub setAffinity { my ($pid, $mask, %flags) = @_; # %flags reserved for future use return 0 if ! _sanitize_set_affinity_args($pid, $mask); return _setAffinity_with_Win32API($pid,$mask) || _setAffinity_with_xs_win32($pid,$mask) || _setAffinity_with_Win32Process($pid,$mask) || _setAffinity_with_taskset($pid,$mask) || _setAffinity_with_xs_sched_setaffinity($pid,$mask) || _setAffinity_with_BSD_Process_Affinity($pid,$mask) || _setAffinity_with_xs_freebsd_setaffinity($pid,$mask) || _setAffinity_with_xs_processor_affinity($pid,$mask) || _setAffinity_with_pbind($pid,$mask) || _setAffinity_with_xs_processor_bind($pid,$mask) || _setAffinity_with_xs_pthread_self_setaffinity($pid,$mask) || _setAffinity_with_bindprocessor($pid,$mask) || _setAffinity_with_cpuset($pid,$mask) || _setAffinity_with_xs_irix_sysmp($pid,$mask) || 0; } our $_NUM_CPUS_CACHED = 0; sub getNumCpus { if ($_NUM_CPUS_CACHED) { return $_NUM_CPUS_CACHED; } return $_NUM_CPUS_CACHED = _getNumCpus_from_xs_Win32API_System_Info() || _getNumCpus_from_xs_cpusetGetCPUCount() || _getNumCpus_from_proc_cpuinfo() || _getNumCpus_from_proc_stat() || _getNumCpus_from_lsdev() || _getNumCpus_from_bindprocessor() || _getNumCpus_from_BSD_Process_Affinity() || _getNumCpus_from_sysctl_freebsd() || _getNumCpus_from_sysctl() || _getNumCpus_from_dmesg_bsd() || _getNumCpus_from_xs_solaris() || _getNumCpus_from_dmesg_solaris() || _getNumCpus_from_psrinfo() || _getNumCpus_from_hinv() || _getNumCpus_from_hwprefs() || _getNumCpus_from_system_profiler() || _getNumCpus_from_Win32API_System_Info() || _getNumCpus_from_Test_Smoke_SysInfo() || _getNumCpus_from_prtconf() # slower than bindprocessor, lsdev || _getNumCpus_from_ENV() || _getNumCpus_from_taskset() || -1; } ###################################################################### # count processors toolbox sub _getNumCpus_from_ENV { # in some OS, the number of processors is part of the default environment # this also makes it easy to spoof the value (is that good or bad?) if ($^O eq 'MSWin32' || $^O eq 'cygwin') { if (defined $ENV{NUMBER_OF_PROCESSORS}) { _debug("from Windows ENV: nproc=$ENV{NUMBER_OF_PROCESSORS}"); return $ENV{NUMBER_OF_PROCESSORS}; } } return 0; } our %WIN32_SYSTEM_INFO = (); our %WIN32API = (); sub __is_wow64 { # determines whether this (Windows) program is running the WOW64 emulator # (to let 32-bit apps run on 64-bit architecture) # used in _getNumCpus_from_Win32API_System_Info to decide whether to use # GetSystemInfo or GetNativeSystemInfo in the Windows API. return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin'; return 0 if !_configModule('Win32::API'); return $Sys::CpuAffinity::IS_WOW64 if $Sys::CpuAffinity::IS_WOW64_INITIALIZED++; my $hmodule = _win32api('GetModuleHandle', 'kernel32'); return 0 if $hmodule == 0; my $proc = _win32api('GetProcAddress', $hmodule, 'IsWow64Process'); return 0 if $proc == 0; my $current = _win32api('GetCurrentProcess'); return 0 if $current == 0; # carp ... my $bool = 0; my $result = _win32api('IsWow64Process', $current, $bool); if ($result != 0) { $Sys::CpuAffinity::IS_WOW64 = $bool; } $Sys::CpuAffinity::IS_WOW64_INITIALIZED++; return $Sys::CpuAffinity::IS_WOW64; } sub _getNumCpus_from_Win32API_System_Info { return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin'; return 0 if !_configModule('Win32::API'); if (0 == scalar keys %WIN32_SYSTEM_INFO) { if (!defined $WIN32API{'GetSystemInfo'}) { my $is_wow64 = __is_wow64(); my $lpsysinfo_type_avail = Win32::API::Type::is_known('LPSYSTEM_INFO'); my $proto = sprintf 'BOOL %s(%s i)', $is_wow64 ? 'GetNativeSystemInfo' : 'GetSystemInfo', $lpsysinfo_type_avail ? 'LPSYSTEM_INFO' : 'PCHAR'; $WIN32API{'GetSystemInfo'} = Win32::API->new('kernel32', $proto); } # does this part break on 64-bit machines? Don't think so. my $buffer = chr(0) x 36; $WIN32API{'GetSystemInfo'}->Call($buffer); ($WIN32_SYSTEM_INFO{'PageSize'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'NumberOfProcessors'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'...'}, $WIN32_SYSTEM_INFO{'...'}) = unpack 'VVVVVVVvv', substr $buffer,4; } return $WIN32_SYSTEM_INFO{'NumberOfProcessors'} || 0; } sub _getNumCpus_from_xs_cpusetGetCPUCount { # NOT TESTED irix if ($XS_LOADED && defined &xs_cpusetGetCPUCount) { return xs_cpusetGetCPUCount(); } else { return 0; } } sub _getNumCpus_from_xs_Win32API_System_Info { if (defined &xs_get_numcpus_from_windows_system_info) { return xs_get_numcpus_from_windows_system_info(); } elsif (defined &xs_get_numcpus_from_windows_system_info_alt) { return xs_get_numcpus_from_windows_system_info_alt(); } else { return 0; } } sub _getNumCpus_from_proc_cpuinfo { # I'm told this could give the wrong answer with a "non-SMP kernel" # http://www-oss.fnal.gov/fss/hypermail/archives/hyp-linux/0746.html return 0 if ! -r '/proc/cpuinfo'; my $num_processors = 0; my $cpuinfo_fh; if (open $cpuinfo_fh, '<', '/proc/cpuinfo') { while (<$cpuinfo_fh>) { if (/^processor\s/) { $num_processors++; } } close $cpuinfo_fh; } _debug("from /proc/cpuinfo: nproc=$num_processors"); return $num_processors || 0; } sub _getNumCpus_from_proc_stat { return 0 if ! -r '/proc/stat'; my $num_processors = 0; my $stat_fh; if (open $stat_fh, '<', '/proc/stat') { while (<$stat_fh>) { if (/^cpu\d/i) { $num_processors++; } } close $stat_fh; } _debug("from /proc/stat: nproc=$num_processors"); return $num_processors || 0; } sub __set_aix_hints { my ($bindprocessor) = @_; our $AIX_HINTS = { READY => 0 }; if (!$bindprocessor) { $bindprocessor = _configExternalProgram('bindprocessor'); } return unless $bindprocessor; my $vp_output = qx('$bindprocessor' -q 2>/dev/null); if ($vp_output !~ s/The available process\S+ are:\s*//) { return; } my @vp = split /\s+/, $vp_output; @vp = sort { $a <=> $b } @vp; $AIX_HINTS->{VIRTUAL_PROCESSORS} = \@vp; my %vp = map {; $_ => -1 } @vp; my $proc_output = qx('$bindprocessor' -s 0 2>/dev/null); if ($proc_output !~ s/The available process\S+ are:\s*//) { $AIX_HINTS->{PROCESSORS} = $AIX_HINTS->{VIRTUAL_PROCESSORS}; $AIX_HINTS->{NUM_CORES} = @vp; return; } my @procs = split /\s+/, $proc_output; @procs = sort { $a <=> $b } @procs; $AIX_HINTS->{PROCESSORS} = \@procs; $AIX_HINTS->{NUM_CORES} = @procs; $AIX_HINTS->{READY} = 1; if (@procs == @vp) { foreach my $proc (@procs) { $AIX_HINTS->{PROC_MAP}{$_} = $_; } } else { my $core = -1; foreach my $proc (@procs) { $core++; my $bound_output = qx('$bindprocessor' -b $proc 2>/dev/null); if ($bound_output =~ s/The available process\S+ are:\s*//) { my @bound_proc = split /\s+/, $bound_output; foreach my $bound_proc (@bound_proc) { $AIX_HINTS->{PROC_MAP}{$bound_proc} = $core; } } } } } sub _is_solarisMultiCpuBinding { our $SOLARIS_HINTS; return unless $^O =~ /solaris/i; if (!$SOLARIS_HINTS || !$SOLARIS_HINTS->{multicpu}) { local $?; my ($maj,$min) = split /[.]/, qx(uname -v); if ($? == 0 && ($maj > 11 || ($maj == 11 && $min >= 2))) { $SOLARIS_HINTS->{multicpu} = 'yes'; } elsif (defined &xs_setaffinity_processor_affinity) { $SOLARIS_HINTS->{multicpu} = 'yes'; } else { $SOLARIS_HINTS->{multicpu} = 'no'; } } return $SOLARIS_HINTS->{multicpu} eq 'yes'; } sub _getNumCpus_from_bindprocessor { return 0 if $^O !~ /aix/i; return 0 if !_configExternalProgram('bindprocessor'); my $cmd = _configExternalProgram('bindprocessor'); our $AIX_HINTS; __set_aix_hints($cmd) unless $AIX_HINTS; return $AIX_HINTS->{NUM_CORES} || 0; #my $bindprocessor_output = qx($cmd -s 0 2>/dev/null); # or $cmd -q ? my $bindprocessor_output = qx($cmd -q 2>/dev/null); # or $cmd -s 0 ? $bindprocessor_output =~ s/\s+$//; return 0 if !$bindprocessor_output; # Typical output: "The available processors are: 0 1 2 3" $bindprocessor_output =~ s/.*:\s+//; my @p = split /\s+/, $bindprocessor_output; return 0+@p; } sub _getNumCpus_from_lsdev { return 0 if $^O !~ /aix/i; return 0 if !_configExternalProgram('lsdev'); my $cmd = _configExternalProgram('lsdev'); my @lsdev_output = qx($cmd -Cc processor 2>/dev/null); return 0+@lsdev_output; } sub _getNumCpus_from_dmesg_bsd { return 0 if $^O !~ /bsd/i; my @dmesg; if (-r '/var/run/dmesg.boot' && open my $fh, '<', '/var/run/dmesg.boot') { @dmesg = <$fh>; close $fh; } elsif (! _configExternalProgram('dmesg')) { return 0; } else { my $cmd = _configExternalProgram('dmesg'); @dmesg = qx($cmd 2> /dev/null); } # on the version of FreeBSD that I have to play with # (8.0), dmesg contains this message: # # FreeBSD/SMP: Multiprocessor System Detected: 2 CPUs # # so we'll go with that. # # on NetBSD, the message is: # # cpu3 at mainbus0 apid 3: AMD 686-class, 1975MHz, id 0x100f53 # try FreeBSD format my @d = grep { /Multiprocessor System Detected:/i } @dmesg; my $ncpus; if (@d > 0) { _debug("dmesg_bsd contains:\n@d"); ($ncpus) = $d[0] =~ /Detected: (\d+) CPUs/i; } # try NetBSD format. This will also probably work for OpenBSD. if (!$ncpus) { # 1.05 - account for duplicates in @dmesg my %d = (); @d = grep { /^cpu\d+ at / } @dmesg; foreach my $dmesg (@d) { if ($dmesg =~ /^cpu(\d+) at /) { $d{$1}++; } } _debug("dmesg_bsd[2] contains:\n",@d); $ncpus = scalar keys %d; } if (@dmesg < 50) { _debug("full dmesg log:\n", @dmesg); } return $ncpus || 0; } sub _getNumCpus_from_xs_solaris { return 0 if $^O !~ /solaris/i; return 0 if !defined &xs_solaris_numCpus; my $n = eval { xs_solaris_numCpus() }; return $n || 0; } sub _getNumCpus_from_sysctl_freebsd { return 0 unless defined &xs_num_cpus_freebsd; return xs_num_cpus_freebsd() || 0; } sub _getNumCpus_from_dmesg_solaris { return 0 if $^O !~ /solaris/i; return 0 if !_configExternalProgram('dmesg'); my $cmd = _configExternalProgram('dmesg'); my @dmesg = qx($cmd 2> /dev/null); # a few clues that I see on my system (opensolaris 5.11 i86pc): # ... blah blah is bound to cpu # ^cpu: x86 blah blah my $ncpus = 0; foreach my $dmesg (@dmesg) { if ($dmesg =~ /is bound to cpu (\d+)/) { my $n = $1; if ($ncpus <= $n) { $ncpus = $n + 1; } } if ($dmesg =~ /^cpu(\d+):/) { my $n = $1; if ($ncpus <= $n) { $ncpus = $n + 1; } } } # this doesn't always work # (www.cpantesters.org/cpan/report/35d7685a-70b0-11e0-9552-4df9775ebe45) # what else should we check for in @dmesg ? if ($ncpus == 0) { # ... } return $ncpus; } sub _getNumCpus_from_sysctl { # sysctl works on a number of systems including MacOS return 0 if !_configExternalProgram('sysctl'); my $cmd = _configExternalProgram('sysctl'); my @sysctl = qx($cmd -a 2> /dev/null); my @results = grep { /^hw.(?:avail|n)cpu\s*[:=]/ } @sysctl; _debug("sysctl output:\n@results"); return 0 if @results == 0; my ($ncpus) = $results[0] =~ /[:=]\s*(\d+)/; if ($ncpus == 0) { my $result = qx($cmd -n hw.ncpu 2> /dev/null); _debug("sysctl[2] result: $result"); $ncpus = 0 + $result; } if ($ncpus == 0) { my $result = qx($cmd -n hw.ncpufound 2> /dev/null); _debug("sysctl[3] result: $result"); $ncpus = 0 + $result; } if ($ncpus == 0) { my $result = qx($cmd -n hw.availcpu 2> /dev/null); _debug("sysctl[4] result: $result"); $ncpus = 0 + $result; } return $ncpus || 0; # there are also sysctl/sysctlbyname system calls } sub _getNumCpus_from_psrinfo { return 0 if !_configExternalProgram('psrinfo'); my $cmd = _configExternalProgram('psrinfo'); my @info = qx($cmd 2> /dev/null); # return scalar grep /core/, qx($cmd -t 2>/dev/null); return scalar @info; } sub _getNumCpus_from_hinv { # NOT TESTED irix return 0 if $^O =~ /irix/i; return 0 if !_configExternalProgram('hinv'); my $cmd = _configExternalProgram('hinv'); # test debug if ($Sys::CpuAffinity::IS_TEST && !$Sys::CpuAffinity::HINV_CALLED++) { print STDERR "$cmd output:\n"; print STDERR qx($cmd); print STDERR "\n\n"; print STDERR "$cmd -c processor output:\n"; print STDERR qx($cmd -c processor); print STDERR "\n\n"; } # found this in Test::Smoke::SysInfo v0.042 in Test-Smoke-1.43 module my @processor = qx($cmd -c processor 2> /dev/null); _debug('"hinv -c processor" output: ', @processor); my ($cpu_cnt) = grep { /\d+.+processors?$/i } @processor; my $ncpu = (split ' ', $cpu_cnt)[0]; if ($ncpu == 0) { # there might be output like: # PU 30 at Module 001c35/Slot 0/Slice C: 400 Mhz MIPS R12000 Processor $ncpu = grep { /^CPU / } @processor; } return $ncpu; } sub _getNumCpus_from_hwprefs { return 0 if $^O !~ /darwin/i && $^O !~ /MacOS/i; return 0 if !_configExternalProgram('hwprefs'); my $cmd = _configExternalProgram('hwprefs'); my $result = qx($cmd cpu_count 2> /dev/null); $result =~ s/\s+$//; _debug("\"$cmd cpu_count\" output: ", $result); return $result || 0; } sub _getNumCpus_from_system_profiler { # NOT TESTED darwin return 0 if $^O !~ /darwin/ && $^O !~ /MacOS/i; return 0 if !_configExternalProgram('system_profiler'); # with help from Test::Smoke::SysInfo my $cmd = _configExternalProgram('system_profiler'); my $system_profiler_output = qx($cmd -detailLevel mini SPHardwardDataType 2> /dev/null); my %system_profiler; while ($system_profiler_output =~ m/^\s*([\w ]+):\s+(.+)$/gm) { $system_profiler{uc $1} = $2; } my $ncpus = $system_profiler{'NUMBER OF CPUS'}; if (!defined $ncpus) { $ncpus = $system_profiler{'TOTAL NUMBER OF CORES'}; } return $ncpus; } sub _getNumCpus_from_prtconf { # solaris has a prtconf command, but I don't think it outputs #cpus. return 0 if $^O !~ /aix/i; return 0 if !_configExternalProgram('prtconf'); my $cmd = _configExternalProgram('prtconf'); # prtconf can take a long time to run, so cache the result our $AIX_prtconf_cache; if (!defined($AIX_prtconf_cache)) { my @result = qx($cmd 2> /dev/null); my ($result) = grep { /Number Of Processors:/ } @result; return 0 if !$result; my ($ncpus) = $result =~ /:\s+(\d+)/; $AIX_prtconf_cache = $ncpus || 0; } return $AIX_prtconf_cache; } sub _getNumCpus_from_Test_Smoke_SysInfo { # NOT TESTED return 0 if !_configModule('Test::Smoke::SysInfo'); my $sysinfo = Test::Smoke::SysInfo->new(); if (defined $sysinfo && defined $sysinfo->{_ncpu}) { # darwin: result might have format "1 [2 cores]", see # www.cpantesters.org/cpan/report/db6067c4-9a66-11e0-91fb-39e97f60f2f7 $sysinfo->{_ncpu} =~ s/\d+ \[(\d+) cores\]/$1/; return $sysinfo->{_ncpu}; } return; } sub _getNumCpus_from_taskset { return 0 if $^O !~ /linux/i; my $taskset = _configExternalProgram('taskset'); return 0 unless $taskset; # neither of these approaches are foolproof # 1. read affinity mask of PID 1 # 2. try different affinity settings until it fails # # also I don't know what will happen if there are >64 cpus my $result = qx($taskset -p 1 2> /dev/null); my ($mask) = $result =~ /:\s+(\w+)/; if ($mask) { my $n = 1+__hex($mask); return int(0.5+log($n)/log(2)); } my $n = 0; do { my $cmd = sprintf '%s -p %x $$', $taskset, 1<<$n; my $result = qx($cmd >/dev/null 2>/dev/null); $n++; } while ($?==0 && $n < 64); if ($n > 1) { # n==1 could be a false positive return $n; } $n = 0; while ( do { qx($taskset -pc $n $$ >/dev/null 2>/dev/null); $?==0 } ) { $n++; last if $n >= 256; } return 0; } ###################################################################### # get affinity toolbox sub _getAffinity_with_Win32API { my $opid = shift; return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin'; return 0 if !_configModule('Win32::API'); my $pid = $opid; if ($^O eq 'cygwin') { $pid = __pid_to_winpid($opid); # return 0 if !defined $pid; } return 0 if !$pid; if ($pid > 0) { return _getProcessAffinity_with_Win32API($pid); } else { # $pid is a Windows pseudo-process (thread ID) return _getThreadAffinity_with_Win32API(-$pid); } } sub _getProcessAffinity_with_Win32API { my $pid = shift; my ($processMask, $systemMask, $processHandle) = (' ' x 16, ' ' x 16); # 0x0400 - PROCESS_QUERY_INFORMATION, # 0x1000 - PROCESS_QUERY_LIMITED_INFORMATION $processHandle = _win32api('OpenProcess',0x0400,0,$pid) || _win32api('OpenProcess',0x1000,0,$pid); return 0 if ! $processHandle; return 0 if ! _win32api('GetProcessAffinityMask', $processHandle, $processMask, $systemMask); my $mask = _unpack_Win32_mask($processMask); _debug("affinity with Win32::API: $mask"); return $mask; } sub _getThreadAffinity_with_Win32API { my $thrid = shift; my ($processMask, $systemMask, $threadHandle) = (' 'x16, ' 'x16); # 0x0020: THREAD_QUERY_INFORMATION # 0x0400: THREAD_QUERY_LIMITED_INFORMATION # 0x0040: THREAD_SET_INFORMATION # 0x0200: THREAD_SET_LIMITED_INFORMATION $threadHandle = _win32api('OpenThread', 0x0060, 0, $thrid) || _win32api('OpenThread', 0x0600, 0, $thrid) || _win32api('OpenThread', 0x0020, 0, $thrid) || _win32api('OpenThread', 0x0400, 0, $thrid); if (! $threadHandle) { return 0; } # The Win32 API does not have a GetThreadAffinityMask function. # SetThreadAffinityMask will return the previous affinity, # but then you have to call it again to restore the original affinity. # Also, SetThreadAffinityMask won't work if you don't have permission # to change the affinity. # SetThreadAffinityMask argument has to be compatible with # process affinity, so get process affinity. # XXX - this function only works for threads that are contained # by the current process, and that should cover most use # cases of this module. But how would you get the process # id of an arbitrary Win32 thread? my $cpid = _win32api('GetCurrentProcessId'); my $processHandle = _win32api('OpenProcess', 0x0400, 0, $cpid) || _win32api('OpenProcess', 0x1000, 0, $cpid); local ($!,$^E) = (0,0); my $result = _win32api('GetProcessAffinityMask', $processHandle, $processMask, $systemMask); if ($result == 0) { carp 'Could not determine process affinity ', "(required to get thread affinity)\n"; return 0; } $processMask = _unpack_Win32_mask($processMask); if ($processMask == 0) { carp 'Process affinity apparently set to zero, ', "will not be able to set/get compatible thread affinity\n"; return 0; } my $previous_affinity = _win32api('SetThreadAffinityMask', $threadHandle, $processMask); if ($previous_affinity == 0) { Carp::cluck "Win32::API::SetThreadAffinityMask: $! / $^E\n"; return 0; } # hope we can restore it. if ($previous_affinity != $processMask) { local $! = 0; local $^E = 0; my $new_affinity = _win32api('SetThreadAffinityMask', $threadHandle, $previous_affinity); if ($new_affinity == 0) { # http://msdn.microsoft.com/en-us/library/ms686247(v=vs.85).aspx: # # "If the thread affinity mask requests a processor that is not # selected for the process affinity mask, the last error code # is ERROR_INVALID_PARAMETER." ($! => 87) # # In MSWin32, the result of a fork() is a "pseudo-process", # a Win32 thread that is still contained by its parent. # So on MSWin32 a race condition exists where the parent # process can choose an incompatible set of affinities # during the execution of this function (basically, between # the two calls to SetThreadAffinityMask , above). carp "Sys::CpuAffinity::_getThreadAffinity_with_Win32API:\n", "set thread $thrid affinity to $processMask ", "in order to retrieve\naffinity, but was unable to ", "restore previous value:\nHandle=$threadHandle, ", "Prev=$previous_affinity, Error=$! / $^E\n"; } } return $previous_affinity; } sub _unpack_Win32_mask { # The Win32 GetProcessAffinityMask function takes # "PDWORD" arguments. We pass (arbitrary) integers for these # arguments, but on return they are changed to 1-4 bytes # representing a packed integer. my $packed = shift; return unpack "L", substr($packed . "\0\0\0\0", 0, 4); } sub _getAffinity_with_Win32Process { my $pid = shift; return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin'; return 0 if !_configModule('Win32::Process'); return 0 if $pid < 0; # pseudo-process / thread id if ($^O eq 'cygwin') { $pid = __pid_to_winpid($pid); return 0 if !defined $pid; } my ($processMask, $systemMask, $result, $processHandle) = (' 'x16, ' 'x16); if (! Win32::Process::Open($processHandle, $pid, 0) || ref($processHandle) ne 'Win32::Process') { return 0; } if (! $processHandle->GetProcessAffinityMask($processMask, $systemMask)) { return 0; } _debug("affinity with Win32::Process: $processMask"); return $processMask; } sub _getAffinity_with_taskset { my $pid = shift; return 0 if $^O ne 'linux'; return 0 if !_configExternalProgram('taskset'); my $taskset = _configExternalProgram('taskset'); my $taskset_output = qx($taskset -p $pid 2> /dev/null); $taskset_output =~ s/\s+$//; _debug("taskset output: $taskset_output"); return 0 if ! $taskset_output; my ($mask) = $taskset_output =~ /: (\S+)/; _debug("affinity with taskset: $mask"); return __hex($mask); } sub __hex { # hex() method with better support for input > 0xffffffff my $mask = shift; if (length($mask) > 8) { my $mask2 = substr($mask,-8); my $mask1 = substr($mask,0,-8); return hex($mask2) + (__hex($mask1) << 32); } else { return hex($mask); } } sub _getAffinity_with_xs_sched_getaffinity { my $pid = shift; return 0 if !defined &xs_sched_getaffinity_get_affinity; my @mask; my $r = xs_sched_getaffinity_get_affinity($pid,\@mask,0); if ($r) { return _arrayToMask(@mask); } return; } sub _getAffinity_with_xs_DEBUG_sched_getaffinity { # to debug errors in xs_sched_getaffinity_get_affinity # during t/11-exercise-all.t my $pid = shift; return 0 if !defined &xs_sched_getaffinity_get_affinity; my @mask; my $r = xs_sched_getaffinity_get_affinity($pid,\@mask,1); if ($r) { return _arrayToMask(@mask); } return; } sub _getAffinity_with_pbind { my ($pid) = @_; return 0 if $^O !~ /solaris/i; return 0 if !_configExternalProgram('pbind'); my $pbind = _configExternalProgram('pbind'); my $cmd = "$pbind -q $pid"; my $pbind_output = qx($cmd 2> /dev/null); if ($pbind_output eq '' && $? == 0) { # pid is unbound or pid is invalid? if (kill 'ZERO', $pid) { $pbind_output = 'not bound'; } else { warn "_getAffinity_with_pbind: could not signal unbound pid $pid"; return; } } # possible output: # process id $pid: $index # process id $pid: not bound # pid \d+ \w+ bound to proccessor(s) \d+ \d+ \d+. if ($pbind_output =~ /not bound/) { my $np = getNumCpus(); if ($np > 0) { return (TWO ** $np) - 1; } else { carp '_getAffinity_with_pbind: ', "process $pid unbound but can't count processors\n"; return TWO**32 - 1; } } elsif ($pbind_output =~ /: (\d+)/) { my $bound_processor = $1; return TWO ** $bound_processor; } elsif ($pbind_output =~ / bound to proces\S+\s+(.+)\.$/) { my $cpus = $1; if (!defined($cpus)) { return 0; } my @cpus = split /\s+/, $1; return _arrayToMask(@cpus); } return 0; } sub _getAffinity_with_psaix { my ($pid) = @_; return 0 if $^O !~ /aix/i; my $pscmd = _configExternalProgram('ps'); return 0 if !$pscmd; our $AIX_HINTS; __set_aix_hints() unless $AIX_HINTS; my ($header,$data) = qx(ps -o THREAD -p $pid 2>/dev/null); return 0 unless $data; $header =~ s/^\s+//; my @h = split /\s+/, $header; my @d = split /\s+/, $data; my ($ipid) = grep { $h[$_] eq 'PID' } 0 .. $#h; my ($ibnd) = grep { $h[$_] eq 'BND' } 0 .. $#h; if ($ipid ne '' && $ibnd) { my $pidd = $d[$ipid]; my $bndd = $d[$ibnd]; if ($pidd == $pid) { $bndd =~ s/^\s+//; $bndd =~ s/\s+$//; if ($bndd eq '-') { # not bound return (TWO ** getNumCpus()) - 1; } if ($AIX_HINTS) { $bndd = $AIX_HINTS->{PROC_MAP}{$bndd} || $bndd; } return TWO ** $bndd; } } warn "ps\\aix: could not parse result:\n$header$data\n"; return 0; } sub _getAffinity_with_xs_processor_affinity { my ($pid) = @_; return 0 if !defined &xs_getaffinity_processor_affinity; my @mask = (); my $ret = xs_getaffinity_processor_affinity($pid,\@mask); if ($ret == 0) { return 0; } _debug("affinity with getaffinity_xs_processor_affinity: @mask"); return _arrayToMask(@mask); } sub _getAffinity_with_xs_processor_bind { my ($pid) = @_; return 0 if !defined &xs_getaffinity_processor_bind; return 0 if $^O !~ /solaris/i; return 0 if _is_solarisMultiCpuBinding(); my @mask = (); my $ret = xs_getaffinity_processor_bind($pid,\@mask); if ($ret == 0) { return 0; } _debug("affinity with getaffinity_xs_processor_affinity: @mask"); return _arrayToMask(@mask); } sub _getAffinity_with_BSD_Process_Affinity { my ($pid) = @_; return 0 if $^O !~ /bsd/i; return 0 if !_configModule('BSD::Process::Affinity','0.04'); my $mask; if (! eval { my $affinity = BSD::Process::Affinity::get_process_mask($pid); $mask = $affinity->get; 1 } ) { # $MODULE{'BSD::Process::Affinity'} = 0 _debug("error in _setAffinity_with_BSD_Process_Affinity: $@"); return 0; } return $mask; } sub _getAffinity_with_cpuset { my ($pid) = @_; return 0 if $^O !~ /bsd/i; return 0 if !_configExternalProgram('cpuset'); my $cpuset = _configExternalProgram('cpuset'); my $cmd = "$cpuset -g -p $pid"; my $cpuset_output = qx($cmd 2> /dev/null); # output format: # pid nnnnn mask: i, j, k, ... $cpuset_output =~ s/.*:\s*//; my @cpus = split /\s*,\s*/, $cpuset_output; if (@cpus > 0) { return _arrayToMask(@cpus); } return 0; } sub _getAffinity_with_xs_freebsd_getaffinity { my $pid = shift; return 0 if !defined &xs_getaffinity_freebsd; my @mask = (); my $ret = xs_getaffinity_freebsd($pid,\@mask,0); if ($ret == 0) { return 0; } return _arrayToMask(@mask); } sub _getAffinity_with_xs_freebsd_getaffinity_debug { my $pid = shift; if (!defined &xs_getaffinity_freebsd) { if ($^O =~ /bsd/) { warn "\$^O=$^O, xs_getaffinity_freebsd not defined"; } return; } my @mask = (); my $ret = xs_getaffinity_freebsd($pid,\@mask,1); warn "return value from xs_getaffinity_freebsd: $ret"; if ($ret == 0) { return 0; } return _arrayToMask(@mask); } sub _getAffinity_with_xs_win32 { my ($opid) = @_; my $pid = $opid; if ($^O =~ /cygwin/) { $pid = __pid_to_winpid($opid); return 0 if !defined $pid; } if ($pid < 0) { return 0 if !defined &xs_win32_getAffinity_thread; return xs_win32_getAffinity_thread(-$pid); } elsif ($opid == $$) { if (defined &xs_win32_getAffinity_proc) { return xs_win32_getAffinity_proc($pid); } elsif (defined &xs_win32_getAffinity_thread) { return xs_win32_getAffinity_thread(0); } else { } return 0; } elsif (defined &xs_win32_getAffinity_proc) { return xs_win32_getAffinity_proc($pid); } return 0; } sub _getAffinity_with_xs_pthread_self_getaffinity { # new in 1.00, may only work when run as root my ($pid) = @_; return 0 if $^O !~ /bsd/; # this function can only be used on the calling process. return 0 if $pid != $$; return 0 if !defined &xs_pthread_self_getaffinity; my $z = xs_pthread_self_getaffinity(0); if ($z == 0) { # does $z==0 mean that the current thread is not bound (i.e., # bound to all processors)? Or does it mean that the # pthread_getaffinity_np() call didn't do anything (but still # returned 0/success?) # Does pthread_getaffinity_np() always return 0 for normal users # and return non-zero for the super-user? # must use $_NUM_CPUS_CACHED || ... to pass test t/12#2 my $np = $_NUM_CPUS_CACHED || getNumCpus(); my $maxmask = TWO ** $np - 1; my $y = _setAffinity_with_xs_pthread_self_setaffinity($pid, $maxmask); if ($y) { return $maxmask; } else { return 0; } } return $z; } sub _getAffinity_with_xs_irix_sysmp { # new in 1.00, not tested my ($pid) = @_; return 0 if $^O !~ /irix/i; return 0 if !defined &xs_irix_sysmp_getaffinity; my $result = xs_irix_sysmp_getaffinity($pid); if ($result < -1) { # error return 0; } elsif ($result == -1) { # unrestricted my $np = getNumCpus(); return TWO ** $np - 1; } else { # restricted to a single processor. return TWO ** $result; } } ###################################################################### # set affinity toolbox sub _setAffinity_with_Win32API { my ($pid, $mask) = @_; return 0 if $^O ne 'MSWin32' && $^O ne 'cygwin'; return 0 if !_configModule('Win32::API'); # if $^O is 'cygwin', make sure you are passing the Windows pid, # using Cygwin::pid_to_winpid if necessary! if ($^O eq 'cygwin') { $pid = __pid_to_winpid($pid); if ($DEBUG) { print STDERR "winpid is $pid ($_[0])\n"; } return 0 if !defined $pid; } if ($pid > 0) { my $processHandle; # 0x0200 - PROCESS_SET_INFORMATION $processHandle = _win32api('OpenProcess', 0x0200,0,$pid); if ($DEBUG) { print STDERR "process handle: $processHandle\n"; } return 0 if ! $processHandle; my $result = _win32api('SetProcessAffinityMask', $processHandle, $mask); _debug("set affinity with Win32::API: $result"); return $result; } else { # negative pid indicates Windows "pseudo-process", which should # use the Thread functions. # Thread access rights definitions: # 0x0020: THREAD_QUERY_INFORMATION # 0x0400: THREAD_QUERY_LIMITED_INFORMATION # 0x0040: THREAD_SET_INFORMATION # 0x0200: THREAD_SET_LIMITED_INFORMATION my $threadHandle; local $! = undef; local $^E = 0; $threadHandle = _win32api('OpenThread', 0x0060, 0, -$pid) || _win32api('OpenThread', 0x0600, 0, -$pid) || _win32api('OpenThread', 0x0040, 0, -$pid) || _win32api('OpenThread', 0x0200, 0, -$pid); return 0 if ! $threadHandle; my $previous_affinity = _win32api('SetThreadAffinityMask', $threadHandle, $mask); if ($previous_affinity == 0) { carp 'Sys::CpuAffinity::_setAffinity_with_Win32API: ', "SetThreadAffinityMask call failed: $! / $^E\n"; } return $previous_affinity; } } sub _setAffinity_with_Win32Process { my ($pid, $mask) = @_; return 0 if $^O ne 'MSWin32'; # cygwin? can't get it to work reliably return 0 if !_configModule('Win32::Process'); if ($^O eq 'cygwin') { $pid = __pid_to_winpid($pid); if ($DEBUG) { print STDERR "cygwin pid $_[0] => winpid $pid\n"; } return 0 if !defined $pid; } my $processHandle; if (! Win32::Process::Open($processHandle, $pid, 0) || ref($processHandle) ne 'Win32::Process') { return 0; } # Seg fault on Cygwin? We really prefer not to use it on Cygwin. local $SIG{SEGV} = 'IGNORE'; # SetProcessAffinityMask: "only available on Windows NT" use Config; my $v = $Config{osvers}; if ($^O eq 'MSWin32' && ($v < 3.51 || $v >= 6.0)) { if ($DEBUG) { print STDERR 'SetProcessAffinityMask ', "not available on MSWin32 osvers $v?\n"; } return 0; } # Don't trust Strawberry Perl $Config{osvers}. Win32::GetOSVersion # is more reliable if it is available. if (_configModule('Win32')) { if (!Win32::IsWinNT()) { if ($DEBUG) { print STDERR 'SetProcessorAffinityMask ', "not available on MSWin32 OS Version $v\n"; } return 0; } } my $result = $processHandle->SetProcessAffinityMask($mask); _debug("set affinity with Win32::Process: $result"); return $result; } sub _setAffinity_with_taskset { my ($pid, $mask) = @_; return 0 if $^O ne 'linux' || !_configExternalProgram('taskset'); my $cmd = sprintf '%s -p %x %d 2>&1', _configExternalProgram('taskset'), $mask, $pid; my $taskset_output = qx($cmd 2> /dev/null); my $taskset_status = $?; if ($taskset_status) { _debug("taskset output: $taskset_output"); } return $taskset_status == 0; } sub _setAffinity_with_xs_sched_setaffinity { my ($pid,$mask) = @_; return 0 if !defined &xs_sched_setaffinity_set_affinity; my @mask = _maskToArray($mask); return xs_sched_setaffinity_set_affinity($pid,\@mask); } sub _setAffinity_with_BSD_Process_Affinity { my ($pid,$mask) = @_; return 0 if $^O !~ /bsd/i; return 0 if !_configModule('BSD::Process::Affinity','0.04'); if (not eval { my $affinity = BSD::Process::Affinity::get_process_mask($pid); $affinity->set($mask)->update; 1}) { _debug("error in _setAffinity_with_BSD_Process_Affinity: $@"); return 0; } } sub _getNumCpus_from_BSD_Process_Affinity { return 0 if $^O !~ /bsd/i; return 0 if !_configModule('BSD::Process::Affinity','0.04'); my $n = BSD::Process::Affinity::current_set()->get; $n = log( $n+1.01 ) / log(2); return int($n); } sub _setAffinity_with_bindprocessor { my ($pid,$mask) = @_; return 0 if $^O !~ /aix/i; return 0 if $pid < 0; return 0 if !_configExternalProgram('bindprocessor'); my $cmd = _configExternalProgram('bindprocessor'); our $AIX_HINTS; __set_aix_hints($cmd) unless $AIX_HINTS; my @mask = _maskToArray($mask); my @cores = map { $AIX_HINTS->{PROCESSORS}[$_] } @mask; if (@cores == $AIX_HINTS->{NUM_CORES}) { return system("'$cmd' -u $pid") == 0; } elsif (@cores > 1) { warn "_setAffinity_with_bindprocessor: will only set one core on aix"; } return system("'$cmd' $pid $cores[0]") == 0; } sub _setAffinity_with_pbind { my ($pid,$mask) = @_; return 0 if $^O !~ /solaris/i; return 0 if !_configExternalProgram('pbind'); my $pbind = _configExternalProgram('pbind'); my @mask = _maskToArray($mask); my $cpus = join ",", @mask; my $np = getNumCpus(); my $c1; if (@mask == $np) { # unbind $c1 = system("'$pbind' -u $pid > /dev/null 2>&1"); } else { $c1 = system("'$pbind' -b -c $cpus -s $pid > /dev/null 2>&1"); } return !$c1; } sub _setAffinity_with_xs_processor_affinity { my ($pid,$mask) = @_; return 0 if $^O !~ /solaris/i; return 0 if !defined &xs_setaffinity_processor_affinity; my @mask = _maskToArray($mask); my $ret = xs_setaffinity_processor_affinity($pid, \@mask); if ($ret == 0) { return 0; } return 1; } sub _setAffinity_with_xs_processor_bind { my ($pid,$mask) = @_; return 0 if $^O !~ /solaris/i; return 0 if !defined &xs_setaffinity_processor_bind; return 0 if _is_solarisMultiCpuBinding(); my @mask = _maskToArray($mask); my $ret = xs_setaffinity_processor_bind($pid, \@mask); if ($ret == 0) { return 0; } return 1; } sub _setAffinity_with_cpuset { my ($pid, $mask) = @_; return 0 if $^O !~ /bsd/i; return 0 if !_configExternalProgram('cpuset'); my $lmask = join ',' => _maskToArray($mask); my $cmd = _configExternalProgram('cpuset') . " -l $lmask -p $pid"; my $c1 = system "$cmd 2> /dev/null"; return !$c1; } sub _setAffinity_with_xs_freebsd_setaffinity { my ($pid,$mask) = @_; return 0 if !defined &xs_setaffinity_freebsd; my @mask = _maskToArray($mask); return xs_setaffinity_freebsd($pid,\@mask); } sub _setAffinity_with_xs_win32 { my ($opid, $mask) = @_; my $pid = $opid; if ($^O =~ /cygwin/) { $pid = __pid_to_winpid($opid); return 0 if !defined $pid; } if ($pid < 0) { if (defined &xs_win32_setAffinity_thread) { my $r = xs_win32_setAffinity_thread(-$pid,$mask); _debug("xs_win32_setAffinity_thread -$pid,$mask => $r"); return $r if $r; } return 0; } elsif ($opid == $$) { if (defined &xs_win32_setAffinity_proc) { _debug('xs_win32_setAffinity_proc $$'); return xs_win32_setAffinity_proc($pid,$mask); } if ($^O eq 'cygwin' && defined &xs_win32_setAffinity_thread) { my $r = xs_win32_setAffinity_thread(0, $mask); return $r if $r; } return 0; } elsif (defined &xs_win32_setAffinity_proc) { my $r = xs_win32_setAffinity_proc($pid, $mask); _debug("xs_win32_setAffinity_proc +$pid,$mask => $r"); return $r; } return 0; } sub _setAffinity_with_xs_pthread_self_setaffinity { # new in 1.00, may only work when run as root my ($pid, $mask) = @_; return 0 if $^O !~ /bsd/i; # this function only works with the calling process return 0 if $$ != $pid; return 0 if !defined &xs_pthread_self_setaffinity; return &xs_pthread_self_setaffinity($mask); } sub _setAffinity_with_xs_irix_sysmp { # new in 1.00, not tested my ($pid, $mask) = @_; return 0 if $^O !~ /irix/i; return 0 if !defined &xs_irix_sysmp_setaffinity; # Like the pbind function in solaris, Irix's sysmp function can only # * bind a process to a single specific CPU, or # * bind a process to all CPUs my @mask = _maskToArray($mask); my $np = getNumCpus(); my $c1; if ($np > 0 && $mask + 1 == TWO ** $np) { return xs_irix_sysmp_setaffinity($pid, -1); } else { my $element = 0; return xs_irix_sysmp_setaffinity($pid, $mask[$element]); } } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub _maskToArray { my ($mask) = @_; my @mask = (); my $i = 0; while ($mask > 0) { if ($mask & 1) { push @mask, $i; } $i++; $mask >>= 1; } return @mask; } sub _arrayToMask { my @procs = @_; my $mask = Math::BigInt->new(0); for my $proc (@procs) { $mask |= TWO ** $proc; } return $mask; } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub __pid_to_winpid { my ($cygwinpid) = @_; if ($] >= 5.008 && defined &Cygwin::pid_to_winpid) { return Cygwin::pid_to_winpid($cygwinpid); } else { return __poor_mans_pid_to_winpid($cygwinpid); } } sub __poor_mans_pid_to_winpid { my ($cygwinpid) = @_; my @psw = qx(/usr/bin/ps -W 2> /dev/null); foreach my $psw (@psw) { $psw =~ s/^[A-Z\s]+//; my ($pid,$ppid,$pgid,$winpid) = split /\s+/, $psw; next if ! $pid; if ($pid == $cygwinpid) { return $winpid; } } warn "Could not resolve cygwin pid $cygwinpid into winpid.\n"; return $cygwinpid; } ###################################################################### # configuration code sub _debug { my @msg = @_; return if !$DEBUG; print STDERR 'Sys::CpuAffinity: ',@msg,"\n"; return; } our %MODULE = (); our %PROGRAM = (); our %INLINE_CODE = (); sub _configModule { my $module = shift; my $version = shift || ""; return $MODULE{$module} if defined $MODULE{$module}; if (eval "require $module") { ## no critic (StringyEval) my $v = eval "\$$module" . "::VERSION"; if (!$@ && (!$version || $version <= $v)) { _debug("module $module is available."); return $MODULE{$module} = 1; } else { _debug("module $module $version not available ($v)"); return $MODULE{$module} = 0; } } else { _debug("module $module $version not available: $@"); return $MODULE{$module} = 0; } } our @PATH = (); sub _configExternalProgram { my $program = shift; return $PROGRAM{$program} if defined $PROGRAM{$program}; if (-x $program) { _debug("Program $program is available in $program"); return $PROGRAM{$program} = $program; } if ($^O ne 'MSWin32') { my $which = qx(which $program 2> /dev/null); $which =~ s/\s+$//; if ($which =~ / not in / # negative output on irix || $which =~ /no \Q$program\E in / # negative output on solaris || $which =~ /Command not found/ # negative output on openbsd || ! -x $which # not executable, may be junk ) { $which = ''; } if ($which) { _debug("Program $program is available in $which"); return $PROGRAM{$program} = $which; } } # poor man's which if (@PATH == 0) { @PATH = split /:/, $ENV{PATH}; push @PATH, split /;/, $ENV{PATH}; push @PATH, '.'; push @PATH, '/sbin', '/usr/sbin'; } foreach my $dir (@PATH) { if (-x "$dir/$program") { _debug("Program $program is available in $dir/$program"); return $PROGRAM{$program} = "$dir/$program"; } } return $PROGRAM{$program} = 0; } ###################################################################### # some Win32::API specific code our %WIN32_API_SPECS = ('GetActiveProcessorCount' => [ 'kernel32', 'DWORD GetActiveProcessorCount(WORD g)' ], 'GetCurrentProcess' => [ 'kernel32', 'HANDLE GetCurrentProcess()' ], 'GetCurrentProcessId' => [ 'kernel32', 'DWORD GetCurrentProcessId()' ], 'GetCurrentThread' => [ 'kernel32', 'HANDLE GetCurrentThread()' ], 'GetCurrentThreadId' => [ 'kernel32', 'int GetCurrentThreadId()' ], 'GetLastError' => [ 'kernel32', 'DWORD GetLastError()' ], 'GetModuleHandle' => [ 'kernel32', 'HMODULE GetModuleHandle(LPCTSTR n)' ], 'GetPriorityClass' => [ 'kernel32', 'DWORD GetPriorityClass(HANDLE h)' ], 'GetProcAddress' => [ 'kernel32', 'DWORD GetProcAddress(HINSTANCE a,LPCTSTR b)' ], # 'DWORD GetProcAddress(HINSTANCE a,LPCWSTR b)' ], 'GetProcessAffinityMask' => [ 'kernel32', 'BOOL GetProcessAffinityMask(HANDLE h,PDWORD a,PDWORD b)' ], 'GetThreadPriority' => [ 'kernel32', 'int GetThreadPriority(HANDLE h)' ], 'IsWow64Process' => [ 'kernel32', 'BOOL IsWow64Process(HANDLE h,PBOOL b)' ], 'OpenProcess' => [ 'kernel32', 'HANDLE OpenProcess(DWORD a,BOOL b,DWORD c)' ], 'OpenThread' => [ 'kernel32', 'HANDLE OpenThread(DWORD a,BOOL b,DWORD c)' ], 'SetProcessAffinityMask' => [ 'kernel32', 'BOOL SetProcessAffinityMask(HANDLE h,DWORD m)' ], 'SetThreadAffinityMask' => [ 'kernel32', 'DWORD SetThreadAffinityMask(HANDLE h,DWORD d)' ], 'SetThreadPriority' => [ 'kernel32', 'BOOL SetThreadPriority(HANDLE h,int n)' ], 'TerminateThread' => [ 'kernel32', 'BOOL TerminateThread(HANDLE h,DWORD x)' ], ); our %WIN32_API_SPECS_ = map { $_ => $WIN32_API_SPECS{$_}[1] } keys %WIN32_API_SPECS; sub _win32api { ## no critic (RequireArgUnpacking) ## (we want spooky action-at-a-distance) my $function = shift; return if !_configModule('Win32::API'); if (!defined $WIN32API{$function}) { __load_win32api_function($function); } return if !defined($WIN32API{$function}) || $WIN32API{$function} == 0; return $WIN32API{$function}->Call(@_); } sub __load_win32api_function { my $function = shift; my $spec = $WIN32_API_SPECS{$function}; if (!defined $spec) { croak "Sys::CpuAffinity: bad Win32::API function request: $function\n"; } local ($!, $^E) = (0, 0); my $spec_ = $WIN32_API_SPECS_{$function}; $WIN32API{$function} = Win32::API->new('kernel32',$spec_); if ($!) { carp 'Sys::CpuAffinity: ', "error initializing Win32::API function $function: $! / $^E\n"; $WIN32API{$function} = 0; } return; } ###################################################################### 1; # End of Sys::CpuAffinity __END__ ###################################################################### =head1 NAME Sys::CpuAffinity - Set CPU affinity for processes =head1 VERSION Version 1.12 =head1 SYNOPSIS use Sys::CpuAffinity; $num_cpus = Sys::CpuAffinity::getNumCpus(); $mask = 1 | 4 | 8 | 16; # prefer CPU's # 0, 2, 3, 4 $success = Sys::CpuAffinity::setAffinity($pid,$mask); $success = Sys::CpuAffinity::setAffinity($pid, \@preferred_cpus); $mask = Sys::CpuAffinity::getAffinity($pid); @cpus = Sys::CpuAffinity::getAffinity($pid); =head1 DESCRIPTION The details of getting and setting process CPU affinities varies greatly from system to system. Even among the different flavors of Unix there is very little in the way of a common interface to CPU affinities. The existing tools and libraries for setting CPU affinities are not very standardized, so that a technique for setting CPU affinities on one system may not work on another system with the same architecture. This module seeks to do one thing and do it well: manipulate CPU affinities through a common interface on as many systems as possible, by any means necessary. The module is composed of several subroutines, each one implementing a different technique to perform a CPU affinity operation. A technique might try to import a Perl module, run an external program that might be installed on your system, or invoke some C code to access your system libraries. Usually, a technique is applicable to only a single or small group of operating systems, and on any particular system, most of the techniques would fail. Regardless of your particular system and configuration, it is hoped that at least one of the techniques will work and you will be able to get and set the CPU affinities of your processes. =head1 DEPENDENCIES No modules are required by Sys::CpuAffinity, but there are techniques for manipulating CPU affinities in other existing modules, and Sys::CpuAffinity will use these modules if they are available: Win32::API, Win32::Process [MSWin32, cygwin] BSD::Process::Affinity [FreeBSD] =head1 CONFIGURATION AND ENVIRONMENT It is important that your C variable is set correctly so that this module can find any external programs on your system that can help it to manipulate CPU affinities (for example, C on Linux, C on FreeBSD). If C<$ENV{DEBUG}> is set to a true value, this module will produce some output that may or may not be good for debugging. =head1 SUPPORTED SYSTEMS The techniques for manipulating CPU affinities for Windows (including Cygwin) and Linux have been refined and tested pretty well. Some techniques applicable to BSD systems (particularly FreeBSD) and Solaris have been tested a little bit. The hope is that this module will include more techniques for more systems in future releases. See the L below for information about how you can help. MacOS, OpenBSD are explicitly not supported, as there does not appear to be any public interface for specifying the CPU affinity of a process directly on those platforms. On NetBSD, getting and setting CPU affinity is supported B, and, AFAICT, B. Which is to say, you can do this: use Sys::CpuAffinity; # run this process on CPUs 0, 1, 3 Sys::CpuAffinity::setAffinity($$, [0, 1, 3]); but not this: use Sys::CpuAffinity; $pid = `ps | grep emacs` + 0; # run another process on CPUs 0, 1, 3 Sys::CpuAffinity::setAffinity($pid, [0, 1, 3]); =head1 SUBROUTINES/METHODS =over 4 =item C<$bitmask = Sys::CpuAffinity::getAffinity($pid)> =item C<@preferred_cpus = Sys::CpuAffinity::getAffinity($pid)> Retrieves the current CPU affinity for the process with the specified process ID. In scalar context, returns a bit-mask of the CPUs that the process has affinity for, with the least significant bit denoting CPU #0. The return value is actually a L value, so it can store a bit mask on systems with an arbitrarily high number of CPUs. In list context, returns a list of integers indicating the indices of the CPU that the process has affinity for. So for example, if a process in an 8 core machine had affinity for cores # 2, 6, and 7, then in scalar context, C would return (1 << 2) | (1 << 6) | (1 << 7) ==> 196 and in list context, it would return (2, 6, 7) A return value of 0 or C indicates an error such as an invalid process ID. =back =over 4 =item C<$success = Sys::CpuAffinity::setAffinity($pid, $bitmask)> =item C<$success = Sys::CpuAffinity::setAffinity($pid, \@preferred_cpus)> Sets the CPU affinity of a process to the specified processors. First argument is the process ID. The second argument is either a bitmask of the desired processors to assign to the PID, or an array reference with the index values of processors to assign to the PID. # two ways to assign to CPU #'s 1 and 4: Sys::CpuAffinity::setAffinity($pid, 0x12); # 0x12 = (1<<1) | (1<<4) Sys::CpuAffinity::setAffinity($pid, [1,4]); As a special case, using a C<$bitmask> value of C<-1> will clear the CPU affinities of a process -- setting the affinity to all available processors. On some platforms, notably AIX and Irix, it is only possible to bind a process to a single CPU. If the processor mask argument to C specifies more than one processor (but less than the total number of processors in your system), then this function might only bind the process one of the specified processors. =back =over 4 =item C<$ncpu = Sys::CpuAffinity::getNumCpus()> Returns the module's best guess about the number of processors on this system. =back =head1 BUGS AND LIMITATIONS This module may not work or produce undefined results on systems with more than 32 CPUs, though support for these larger systems has improved with v1.07. Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 INCOMPATIBILITIES None known, but they are likely to arise as this module makes a lot of assumptions about how to provide input and interpret output for many different system utilities on many different platforms. Please report a bug if you suspect this module of misusing any system utilities. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Sys::CpuAffinity You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 NOTE TO DEVELOPERS This module seeks to work for as many systems in as many configurations as possible. If you know of a tool, a function, a technique to set CPU affinities on a system -- any system, -- then let's include it in this module. Feel free to submit code through this module's request tracker: L or directly to me at C<< >> and it will be included in the next release. =head1 ACKNOWLEDGEMENTS L for demonstrating how to get/set affinities on BSD systems. L has some fairly portable code for detecting the number of processors. L provided a free OpenBSD account that allowed this module to be tested on that platform. =head1 AUTHOR Marty O'Brien, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2010-2017 Marty O'Brien. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut ###################################################################### Notes and to do list: Why worry about CPU affinity? See http://www.ibm.com/developerworks/linux/library/l-affinity.html?ca=dgr-lnxw41Affinity Other reasons are: bind expensive processes to subset of CPUs, leaving at least one CPU for other tasks or other users See http://www.ibm.com/developerworks/aix/library/au-processinfinity.html for hints about cpu affinity on AIX From v0.90, test to get num CPUs failed on Irix. Rumors of cpu affinity on other systems: BSD: pthread_setaffinity_np(), pthread_getaffinity_np() copy XS code from BSD::Resource::Affinity FreeBSD: /cpuset, cpuset_setaffinity(), cpuset_getaffinity() NetBSD: /psrset Irix: /dplace, cpusetXXX() methods (with -lcpuset) pthread_setrunon_np(int), pthread_getrunon_np(int*) to affine the current thread with a single CPU. sysmp(MP_MUSTRUN_PID,cpu_id,process_id) sysmp(MP_RUNANYWHERE_PID,process_id) sysmp(MP_GETMUSTRUN_PID,process_id) for binding a process to a single specific processor Solaris: /pbind, /psrset, processor_bind(), pset_bind() using /psrset in this module is not recommended * processor sets are *exclusive*. processors assigned to a processor set can only be used by processes assigned to that set * processor sets can only be changed by sysadmin * /cpuset in Irix has these same issues (different from /cpuset command in FreeBSD) Solaris: Solaris::Lgrp module lgrp_affinity_set(P_PID,$pid,$lgrp,LGRP_AFF_xxx) lgrp_affinity_get(P_PID,$pid,$lgrp) affinity_get AIX: /bindprocessor, bindprocessor() in bindprocessor -q lists virtual processors bindprocessor -s 0 lists available cores lsdev -Cc processor lists available cores, consistent with bind... -s 0 bindprocessor -u pid unbind process pid MacOS: thread_policy_set(),thread_policy_get() in In MacOS it is possible to assign threads to the same processor, but generally not to assign them to any particular processor. MacOS is totally unsupported for now. DragonflyBSD: all CPAN tests are from single-core systems, so who knows whether any of this code works on that platform. There also hasn't been a CPAN tester with AIX yet. how to find the number of processors: AIX: sysconf(_SC_NPROCESSORS_CONF), sysconf(_SC_NPROCESSORS_ONLN) prtconf | grep "Number Of Processors:" | cut -d: -f2 Solaris: processor_info(), p_online() MacOS: hwprefs cpu_count, system_profiler | grep Cores: | cut -d: -f2 do something with `sysctl -a` AIX: prtconf solaris also has prtconf, but don't think it has cpu data BSD also has `sysctl`, they tell me AIX: `smtctl | grep "Bind processor "` ... not reliable AIX: `lsdev -Cc processor` -- all processors AIX: `bindprocessor -q` -- all shares of processors Some systems have a concept of "processor groups" or "cpu sets" that can we could either exploit or be exploited by Some systems have a concept of "strong" affinity and "weak" affinity. Where the distinction is important, let's use "strong" affinity by default. Some systems have a concept of the maximum number of processors that they can suppport. Currently (0.91-1.04), constant parameters to Win32 API functions are hard coded, not extracted from the local header files. ########################################## Issues in 1.02-1.04 1. darwin: hwprefs and sysctl give different results? www.cpantesters.org/cpan/report/3982d2fa-9c2a-11e0-a04e-9d9517dc0771 2. openbsd: dmesg_bsd and sysctl give different results? www.cpantesters.org/cpan/report/84d41dda-9942-11e0-a324-58f41aecacb6 www.cpantesters.org/cpan/report/0c6e981c-a2dd-11e0-a324-58f41aecacb6 3. linux: /usr/bin/taskset available but still cannot count CPUs? (x16) /www.cpantesters.org/cpan/report/92ab9df8-a6fc-11e0-829d-5250641c9bbe xs_sched_getaffinity keeps segfaulting (x4) 4. getNumCpus_from_Win32API_System_Info: garbage result on WOW64 systems Issues in 1.09 1. linux might have more than 64 cpus, so xs_sched_getaffinity_get_affinity and xs_sched_setaffinity_set_affinity should also work in AV space; see Linux::CPUAffinity 2. fix setaffinity_processor_bind.xs, getaffinity_processor_bind.xs for solaris 3. Not tested on Windows 10 4. Solaris XS. processor_bind usage matches old processor_bind man page, not current page, doesn't look like you can use processor_bind() on more than one core. Solaris 11.2 has "Multi-CPU Binding" and we may need to distinguish between systems that have it and systems that don't. blogs.oracle.com/observatory/entry/multi_cpu_binding_mcb: ``[MCB] is available through a new API called "processor_affinity(2)"'' Sys-CpuAffinity-1.12/lib/xs000755034434000144 013036166657 16327 5ustar00mobrien112general000000000000Sys-CpuAffinity-1.12/lib/xs/foo000444034434000144 013036166657 17100 0ustar00mobrien112general000000000000