Add bindings to GNU sched_setaffinity' and sched_getaffinity'.

* configure.ac: Add checks for `sched_setaffinity' and
  `sched_getaffinity'.

* doc/ref/posix.texi (Processes): Document `getaffinity' and
  `setaffinity'.

* libguile/posix.c (cpu_set_to_bitvector,
  scm_getaffinity)[HAVE_SCHED_GETAFFINITY]: New functions.
  (scm_setaffinity)[HAVE_SCHED_SETAFFINITY]: New function.

* libguile/posix.h (scm_getaffinity, scm_setaffinity): New declarations.

* test-suite/tests/posix.test ("affinity"): New test prefix.

configure.ac

@@ -751,8 +751,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #   strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
 #   nl_langinfo - X/Open, not available on Windows.
 #   utimensat: posix.1-2008
+#   sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
 #
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo utimensat])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo utimensat sched_getaffinity sched_setaffinity])
 
 # Reasons for testing:
 #   netdb.h - not in mingw

doc/ref/posix.texi

@@ -1830,6 +1830,28 @@ the highest priority (lowest numerical value) of any of the
 specified processes.
 @end deffn
 
+@cindex affinity, CPU
+
+@deffn {Scheme Procedure} getaffinity pid
+@deffnx {C Function} scm_getaffinity (pid)
+Return a bitvector representing the CPU affinity mask for
+process @var{pid}.  Each CPU the process has affinity with
+has its corresponding bit set in the returned bitvector.
+The number of bits set is a good estimate of how many CPUs
+Guile can use without stepping on other processes' toes.
+
+Currently this procedure is only defined on GNU variants.
+@end deffn
+
+@deffn {Scheme Procedure} setaffinity pid mask
+@deffnx {C Function} scm_setaffinity (pid, mask)
+Install the CPU affinity mask @var{mask}, a bitvector, for
+the process or thread with ID @var{pid}.  The return value
+is unspecified.
+
+Currently this procedure is only defined on GNU variants.
+@end deffn
+
 
 @node Signals
 @subsection Signals

libguile/posix.c

@@ -1903,6 +1903,89 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
 #undef FUNC_NAME
 #endif /* HAVE_SETPRIORITY */
 
+#ifdef HAVE_SCHED_GETAFFINITY
+
+static SCM
+cpu_set_to_bitvector (const cpu_set_t *cs)
+{
+  SCM bv;
+  size_t cpu;
+
+  bv = scm_c_make_bitvector (sizeof (*cs), SCM_BOOL_F);
+
+  for (cpu = 0; cpu < sizeof (*cs); cpu++)
+    {
+      if (CPU_ISSET (cpu, cs))
+	/* XXX: This is inefficient but avoids code duplication.  */
+	scm_c_bitvector_set_x (bv, cpu, SCM_BOOL_T);
+    }
+
+  return bv;
+}
+
+SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
+	    (SCM pid),
+	    "Return a bitvector representing the CPU affinity mask for\n"
+	    "process @var{pid}.  Each CPU the process has affinity with\n"
+	    "has its corresponding bit set in the returned bitvector.\n"
+	    "The number of bits set is a good estimate of how many CPUs\n"
+	    "Guile can use without stepping on other processes' toes.\n\n"
+	    "Currently this procedure is only defined on GNU variants.\n")
+#define FUNC_NAME s_scm_getaffinity
+{
+  int err;
+  cpu_set_t cs;
+
+  CPU_ZERO (&cs);
+  err = sched_getaffinity (scm_to_int (pid), sizeof (cs), &cs);
+  if (err)
+    SCM_SYSERROR;
+
+  return cpu_set_to_bitvector (&cs);
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_SCHED_GETAFFINITY */
+
+#ifdef HAVE_SCHED_SETAFFINITY
+
+SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
+	    (SCM pid, SCM mask),
+	    "Install the CPU affinity mask @var{mask}, a bitvector, for\n"
+	    "the process or thread with ID @var{pid}.  The return value\n"
+	    "is unspecified.\n\n"
+	    "Currently this procedure is only defined on GNU variants.\n")
+#define FUNC_NAME s_scm_setaffinity
+{
+  cpu_set_t cs;
+  scm_t_array_handle handle;
+  const scm_t_uint32 *c_mask;
+  size_t len, off, cpu;
+  ssize_t inc;
+  int err;
+
+  c_mask = scm_bitvector_elements (mask, &handle, &off, &len, &inc);
+
+  CPU_ZERO (&cs);
+  for (cpu = 0; cpu < len; cpu++)
+    {
+      size_t idx;
+
+      idx = cpu * inc + off;
+      if (c_mask[idx / 32] & (1UL << (idx % 32)))
+	CPU_SET (cpu, &cs);
+    }
+
+  err = sched_setaffinity (scm_to_int (pid), sizeof (cs), &cs);
+  if (err)
+    SCM_SYSERROR;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_SCHED_SETAFFINITY */
+
 #if HAVE_GETPASS
 SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, 
             (SCM prompt),
@@ -2078,7 +2161,7 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #undef FUNC_NAME
 #endif /* HAVE_GETHOSTNAME */
 
-
+
 void
 scm_init_posix ()
 {

libguile/posix.h

@@ -89,6 +89,8 @@ SCM_API SCM scm_getpass (SCM prompt);
 SCM_API SCM scm_flock (SCM file, SCM operation);
 SCM_API SCM scm_sethostname (SCM name);
 SCM_API SCM scm_gethostname (void);
+SCM_API SCM scm_getaffinity (SCM pid);
+SCM_API SCM scm_setaffinity (SCM pid, SCM cpu_set);
 SCM_INTERNAL void scm_init_posix (void);
 
 SCM_INTERNAL scm_i_pthread_mutex_t scm_i_locale_mutex;

test-suite/tests/posix.test

@@ -180,3 +180,21 @@
                    (= (stat:mtime info) modified)))))
         (lambda ()
           (delete-file file))))))
+
+;;
+;; affinity
+;;
+
+(with-test-prefix "affinity"
+
+  (pass-if "getaffinity"
+    (if (defined? 'getaffinity)
+        (> (bitvector-length (getaffinity (getpid))) 0)
+        (throw 'unresolved)))
+
+  (pass-if "setaffinity"
+    (if (and (defined? 'setaffinity) (defined? 'getaffinity))
+        (let ((mask (getaffinity (getpid))))
+          (setaffinity (getpid) mask)
+          (equal? mask (getaffinity (getpid))))
+        (throw 'unresolved))))