Check for working profiling and virtual itimers

* configure.ac (HAVE_USABLE_GETITIMER_PROF, HAVE_USABLE_GETITIMER_VIRTUAL): new tests
* doc/ref/posix.texi (setitimer, getitimer): document provided? 'ITIMER_VIRTUAL and 'ITIMER_PROF
* doc/ref/statprof.texi (statprof): document ITIMER_PROF requirements
* libguile/scmsigs.c (scm_setitimer, scm_getitimer): document (provided? 'ITIMER_VIRTUAL) and (provided? 'ITIMER_READ)
  (scm_init_scmsigs): add features ITIMER_VIRTUAL and ITIMER_PROF
* test-suite/tests/asyncs.test ("prevention via sigprof"): throw when unsupported
* test-suite/tests/signals.test: throw when not supported
* test-suite/tests/statprof.test: throw when not supported

configure.ac

@@ -5,7 +5,7 @@ dnl
 define(GUILE_CONFIGURE_COPYRIGHT,[[
 
 Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-  2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation, Inc.
+  2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc.
 
 This file is part of GUILE
 
@@ -880,6 +880,57 @@ main (void)
   esac
 fi
 
+# Cygwin and Hurd (circa 2017) and various prior versions defined stub
+# versions of the virtual and profiling itimers that would always fail
+# when called.
+if test "$ac_cv_func_getitimer" = yes; then
+
+  AC_CACHE_CHECK([whether getitimer(ITIMER_PROF) is usable],
+    guile_cv_use_getitimer_prof,
+    [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/time.h>
+int
+main (void)
+{
+  struct itimerval I;
+  if (getitimer (ITIMER_PROF, &I) == 0)
+    return 0;  /* good */
+  else
+    return 1;  /* bad */
+}]])],
+    [guile_cv_use_getitimer_prof=yes],
+    [guile_cv_use_getitimer_prof=no],
+    [guile_cv_use_getitimer_prof="yes, hopefully (cross-compiling)"])])
+  case $guile_cv_use_getitimer_prof in
+    yes*)
+      AC_DEFINE([HAVE_USABLE_GETITIMER_PROF], 1, [Define to 1 if getitimer(ITIMER_PROF, ...) is functional])
+      ;;
+  esac
+
+  AC_CACHE_CHECK([whether getitimer(ITIMER_VIRTUAL) is usable],
+    guile_cv_use_getitimer_virtual,
+    [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/time.h>
+int
+main (void)
+{
+  struct itimerval I;
+  if (getitimer (ITIMER_VIRTUAL, &I) == 0)
+    return 0;  /* good */
+  else
+    return 1;  /* bad */
+}]])],
+    [guile_cv_use_getitimer_virtual=yes],
+    [guile_cv_use_getitimer_virtual=no],
+    [guile_cv_use_getitimer_virtual="yes, hopefully (cross-compiling)"])])
+  case $guile_cv_use_getitimer_virtual in
+    yes*)
+      AC_DEFINE([HAVE_USABLE_GETITIMER_VIRTUAL], 1, [Define to 1 if getitimer(ITIMER_VIRTUAL, ...) is functional])
+      ;;
+  esac
+fi
+
+
 AC_CACHE_SAVE
 
 dnl GMP tests

doc/ref/posix.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
-@c   2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+@c   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node POSIX
@@ -2196,6 +2196,13 @@ previous setting, in the same form as @code{getitimer} returns.
 
 Although the timers are programmed in microseconds, the actual
 accuracy might not be that high.
+
+Note that @code{ITIMER_PROF} and @code{ITIMER_VIRTUAL} are not
+functional on all platforms and may always error when called.
+@code{(provided? 'ITIMER_PROF)} and @code{(provided? 'ITIMER_VIRTUAL)}
+can be used to test if the those itimers are supported on the given
+host.  @code{ITIMER_REAL} is supported on all platforms that support
+@code{setitimer}.
 @end deffn
 
 

doc/ref/statprof.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2013, 2015 Free Software Foundation, Inc.
+@c Copyright (C) 2013, 2015, 2017 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Statprof
@@ -128,6 +128,10 @@ After the @var{thunk} has been profiled, print out a profile to
 @var{port}.  If @var{display-style} is @code{flat}, the results will be
 printed as a flat profile.  Otherwise if @var{display-style} is
 @code{tree}, print the results as a tree profile.
+
+Note that @code{statprof} requires a working profiling timer. Some
+platforms do not support profiling timers.  @code{(provided?
+'ITIMER_PROF)} can be used to check for support of profiling timers.
 @end deffn
 
 Profiling can also be enabled and disabled manually.

libguile/scmsigs.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006,
- *   2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
+ *   2007, 2008, 2009, 2011, 2013, 2014, 2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -554,7 +554,13 @@ SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
             "The return value will be a list of two cons pairs representing the\n"
             "current state of the given timer.  The first pair is the seconds and\n"
             "microseconds of the timer @code{it_interval}, and the second pair is\n"
-            "the seconds and microseconds of the timer @code{it_value}.")
+            "the seconds and microseconds of the timer @code{it_value}."
+	    "\n"
+	    "@code{ITIMER_PROF} or @code{ITIMER_VIRTUAL} are not supported on\n"
+	    "some platforms and will always error. @code{(provided? 'ITIMER_PROF)}\n"
+	    "and @code{(provided? 'ITIMER_VIRTUAL)} report whether those timers\n"
+	    "are supported.\n")
+
 #define FUNC_NAME s_scm_setitimer
 {
   int rv;
@@ -591,7 +597,12 @@ SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
             "The return value will be a list of two cons pairs representing the\n"
             "current state of the given timer.  The first pair is the seconds and\n"
             "microseconds of the timer @code{it_interval}, and the second pair is\n"
-            "the seconds and microseconds of the timer @code{it_value}.")
+            "the seconds and microseconds of the timer @code{it_value}."
+	    "\n"
+	    "@code{ITIMER_PROF} or @code{ITIMER_VIRTUAL} are not supported on\n"
+	    "some platforms and will always error. @code{(provided? 'ITIMER_PROF)}\n"
+	    "and @code{(provided? 'ITIMER_VIRTUAL)} report whether those timers\n"
+	    "are supported.\n")
 #define FUNC_NAME s_scm_getitimer
 {
   int rv;
@@ -726,6 +737,12 @@ scm_init_scmsigs ()
   scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
   scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
   scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
+#ifdef HAVE_USABLE_GETITIMER_PROF
+  scm_add_feature ("ITIMER_PROF");
+#endif
+#ifdef HAVE_USABLE_GETITIMER_VIRTUAL
+  scm_add_feature ("ITIMER_VIRTUAL");
+#endif
 #endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */
 
 #include "libguile/scmsigs.x"

test-suite/tests/asyncs.test

@@ -1,6 +1,6 @@
 ;;;; asyncs.test                     -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2016 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2016, 2017 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -51,7 +51,8 @@
         (setitimer ITIMER_PROF 0 0 0 0)
         (sigaction SIGPROF prev-handler)))))
 
-(when (defined? 'setitimer)
+(when (and (defined? 'setitimer)
+           (provided? 'ITIMER_PROF))
   (pass-if "preemption via sigprof"
     ;; Use an atomic box as a compiler barrier.
     (let* ((box (make-atomic-box 0))

test-suite/tests/signals.test

@@ -1,6 +1,6 @@
 ;;;; signals.test --- test suite for Guile's signal functions       -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2009, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2014, 2017 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -41,17 +41,25 @@
         (equal? (setitimer ITIMER_REAL 0 0 0 0)
                 '((0 . 0) (0 . 0))))
       (pass-if "ITIMER_VIRTUAL"
+        (if (not (provided? 'ITIMER_VIRTUAL))
+            (throw 'unsupported)
             (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0)
-                '((0 . 0) (0 . 0))))
-      (pass-if "ITIMER_PROF"
-        (equal? (setitimer ITIMER_PROF 0 0 0 0)
                     '((0 . 0) (0 . 0)))))
+      (pass-if "ITIMER_PROF"
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
+            (equal? (setitimer ITIMER_PROF 0 0 0 0)
+                    '((0 . 0) (0 . 0))))))
 
     (with-test-prefix "setting values correctly"
       (pass-if "initial setting"
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
             (equal? (setitimer ITIMER_PROF 1 0 3 0)
-                '((0 . 0) (0 . 0))))
+                    '((0 . 0) (0 . 0)))))
       (pass-if "reset to zero"
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
             (match (setitimer ITIMER_PROF 0 0 0 0)
               ((interval value)
                ;; We don't presume that the timer is strictly lower than the
@@ -59,13 +67,17 @@
                ;; precision.  Assert instead that the timer is between 2 and
                ;; 3.5 seconds.
                (and (<= 0.9 (time-pair->secs interval) 1.1)
-                (<= 2.0 (time-pair->secs value) 3.5))))))
+                    (<= 2.0 (time-pair->secs value) 3.5)))))))
 
     (with-test-prefix "usecs > 1e6"
       (pass-if "initial setting"
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
             (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6)
-                '((0 . 0) (0 . 0))))
+                    '((0 . 0) (0 . 0)))))
       (pass-if "reset to zero"
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
             (match (setitimer ITIMER_PROF 0 0 0 0)
               ((interval value)
                ;; We don't presume that the timer is strictly lower than the
@@ -76,4 +88,4 @@
                     (<= 2.0 (time-pair->secs value) 3.5)
                     (match value
                       ((secs . usecs)
-                   (<= 0 usecs 999999))))))))))
+                       (<= 0 usecs 999999)))))))))))

test-suite/tests/statprof.test

@@ -1,4 +1,5 @@
-;; guile-lib                    -*- scheme -*-
+;;;; statprof.test --- test suite for Guile's profiler       -*- scheme -*-
+;;;; Copyright (C) 2017 Free Software Foundation, Inc.
 ;; Copyright (C) 2004, 2009, 2010, 2014 Andy Wingo <wingo at pobox dot com>
 ;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
 
@@ -31,9 +32,9 @@
   #:use-module (srfi srfi-1)
   #:use-module (statprof))
 
-;; Throw `unresolved' upon ENOSYS.  This is used to skip tests on
+;; Throw `unresolved' upon ENOSYS or EINVAL.  This is used to skip tests
-;; platforms such as GNU/Hurd where `ITIMER_PROF' is is currently
+;; on platforms such as GNU/Hurd or Cygwin where `ITIMER_PROF' is is
-;; unimplemented.
+;; currently unimplemented.
 (define-syntax-rule (when-implemented body ...)
   (catch 'system-error
     (lambda ()
@@ -41,7 +42,7 @@
     (lambda args
       (let ((errno (system-error-errno args)))
         (false-if-exception (statprof-stop))
-        (if (= errno ENOSYS)
+        (if (or (= errno ENOSYS) (= errno EINVAL))
             (throw 'unresolved)
             (apply throw args))))))