Check for working profiling and virtual itimerswip-itimer-checks

* 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

7 files changed, 148 insertions, 55 deletions

diff --git a/configure.ac b/configure.ac
index 8c90d3feb..24ee878d5 100644
--- a/configure.ac
+++ b/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
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 64e668d17..5cb68a292 100644
--- a/doc/ref/posix.texi
+++ b/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
@@ -2162,12 +2162,12 @@ expiry will be signalled.
 A real-time timer, counting down elapsed real time.  At zero it raises
 @code{SIGALRM}.  This is like @code{alarm} above, but with a higher
 resolution period.
-@end defvar 
+@end defvar
 
 @defvar ITIMER_VIRTUAL
 A virtual-time timer, counting down while the current process is
 actually using CPU.  At zero it raises @code{SIGVTALRM}.
-@end defvar 
+@end defvar
 
 @defvar ITIMER_PROF
 A profiling timer, counting down while the process is running (like
@@ -2176,7 +2176,7 @@ process's behalf.  At zero it raises a @code{SIGPROF}.
 
 This timer is intended for profiling where a program is spending its
 time (by looking where it is when the timer goes off).
-@end defvar 
+@end defvar
 
 @code{getitimer} returns the restart timer value and its current value,
 as a list containing two pairs.  Each pair is a time in seconds and
@@ -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
 
 
diff --git a/doc/ref/statprof.texi b/doc/ref/statprof.texi
index 65f0d473b..850c5bd2e 100644
--- a/doc/ref/statprof.texi
+++ b/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,17 +128,21 @@ 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.
 
-@deffn {Scheme Procedure} statprof-active? 
+@deffn {Scheme Procedure} statprof-active?
 Returns @code{#t} if @code{statprof-start} has been called more times
 than @code{statprof-stop}, @code{#f} otherwise.
 @end deffn
 
-@deffn {Scheme Procedure} statprof-start 
-@deffnx {Scheme Procedure} statprof-stop 
+@deffn {Scheme Procedure} statprof-start
+@deffnx {Scheme Procedure} statprof-stop
 Start or stop the profiler.
 @end deffn
 
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index f210380e8..21b2a9529 100644
--- a/libguile/scmsigs.c
+++ b/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;
@@ -601,10 +612,10 @@ SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
   c_which_timer = SCM_NUM2INT(1, which_timer);
 
   SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));
-  
+
   if(rv != 0)
     SCM_SYSERROR;
-  
+
   return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
 			       scm_from_long (old_timer.it_interval.tv_usec)),
 		     scm_cons (scm_from_long (old_timer.it_value.tv_sec),
@@ -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"
diff --git a/test-suite/tests/asyncs.test b/test-suite/tests/asyncs.test
index 437927a81..4ac9020c4 100644
--- a/test-suite/tests/asyncs.test
+++ b/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))
diff --git a/test-suite/tests/signals.test b/test-suite/tests/signals.test
index ef61aaa83..ac730a91e 100644
--- a/test-suite/tests/signals.test
+++ b/test-suite/tests/signals.test
@@ -1,17 +1,17 @@
 ;;;; 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
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free
 ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
@@ -41,39 +41,51 @@
         (equal? (setitimer ITIMER_REAL 0 0 0 0)
                 '((0 . 0) (0 . 0))))
       (pass-if "ITIMER_VIRTUAL"
-        (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0)
-                '((0 . 0) (0 . 0))))
+        (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)))))
+        (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"
-        (equal? (setitimer ITIMER_PROF 1 0 3 0)
-                '((0 . 0) (0 . 0))))
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
+            (equal? (setitimer ITIMER_PROF 1 0 3 0)
+                    '((0 . 0) (0 . 0)))))
       (pass-if "reset to zero"
-        (match (setitimer ITIMER_PROF 0 0 0 0)
-          ((interval value)
-           ;; We don't presume that the timer is strictly lower than the
-           ;; value at which we set it, given its limited internal
-           ;; 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))))))
+        (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
+               ;; value at which we set it, given its limited internal
+               ;; 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)))))))
 
     (with-test-prefix "usecs > 1e6"
       (pass-if "initial setting"
-        (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6)
-                '((0 . 0) (0 . 0))))
+        (if (not (provided? 'ITIMER_PROF))
+            (throw 'unsupported)
+            (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6)
+                    '((0 . 0) (0 . 0)))))
       (pass-if "reset to zero"
-        (match (setitimer ITIMER_PROF 0 0 0 0)
-          ((interval value)
-           ;; We don't presume that the timer is strictly lower than the
-           ;; value at which we set it, given its limited internal
-           ;; 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)
-                (match value
-                  ((secs . usecs)
-                   (<= 0 usecs 999999))))))))))
+        (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
+               ;; value at which we set it, given its limited internal
+               ;; 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)
+                    (match value
+                      ((secs . usecs)
+                       (<= 0 usecs 999999)))))))))))
diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test
index a597f3198..994d88269 100644
--- a/test-suite/tests/statprof.test
+++ b/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
-;; platforms such as GNU/Hurd where `ITIMER_PROF' is is currently
-;; unimplemented.
+;; Throw `unresolved' upon ENOSYS or EINVAL.  This is used to skip tests
+;; on platforms such as GNU/Hurd or Cygwin where `ITIMER_PROF' is is
+;; 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))))))
 
@@ -125,7 +126,7 @@
       (define do-nothing
         (compile '(lambda (n)
                     (simple-format #f "FOO ~A\n" (+ n n)))))
-    
+
       ;; Run test.
       (statprof-reset 0 50000 #t #f)
       (statprof-start)
@@ -136,7 +137,7 @@
           (loop (- x 1))
           #t)))
       (statprof-stop)
-    
+
       ;; Check result.
       (let ((proc-data (statprof-proc-call-data do-nothing)))
         (and proc-data