+;; Type of the second argument to `getitimer' and
+;; the second and third arguments `setitimer'.
+(define-alien-type nil
+ (struct itimerval
+ (it-interval (struct timeval)) ; timer interval
+ (it-value (struct timeval)))) ; current value
+
+(defconstant itimer-real 0)
+(defconstant itimer-virtual 1)
+(defconstant itimer-prof 2)
+
+#!-win32
+(defun unix-getitimer (which)
+ "Unix-getitimer returns the INTERVAL and VALUE slots of one of
+ three system timers (:real :virtual or :profile). On success,
+ unix-getitimer returns 5 values,
+ T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
+ (declare (type (member :real :virtual :profile) which)
+ (values t
+ (unsigned-byte 29) (mod 1000000)
+ (unsigned-byte 29) (mod 1000000)))
+ (let ((which (ecase which
+ (:real itimer-real)
+ (:virtual itimer-virtual)
+ (:profile itimer-prof))))
+ (with-alien ((itv (struct itimerval)))
+ (syscall* ("getitimer" int (* (struct itimerval)))
+ (values t
+ (slot (slot itv 'it-interval) 'tv-sec)
+ (slot (slot itv 'it-interval) 'tv-usec)
+ (slot (slot itv 'it-value) 'tv-sec)
+ (slot (slot itv 'it-value) 'tv-usec))
+ which (alien-sap (addr itv))))))
+
+#!-win32
+(defun unix-setitimer (which int-secs int-usec val-secs val-usec)
+ " Unix-setitimer sets the INTERVAL and VALUE slots of one of
+ three system timers (:real :virtual or :profile). A SIGALRM signal
+ will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
+ when non-zero, is <seconds+microseconds> to be loaded each time
+ the timer expires. Setting INTERVAL and VALUE to zero disables
+ the timer. See the Unix man page for more details. On success,
+ unix-setitimer returns the old contents of the INTERVAL and VALUE
+ slots as in unix-getitimer."
+ (declare (type (member :real :virtual :profile) which)
+ (type (unsigned-byte 29) int-secs val-secs)
+ (type (integer 0 (1000000)) int-usec val-usec)
+ (values t
+ (unsigned-byte 29) (mod 1000000)
+ (unsigned-byte 29) (mod 1000000)))
+ (let ((which (ecase which
+ (:real itimer-real)
+ (:virtual itimer-virtual)
+ (:profile itimer-prof))))
+ (with-alien ((itvn (struct itimerval))
+ (itvo (struct itimerval)))
+ (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
+ (slot (slot itvn 'it-interval) 'tv-usec) int-usec
+ (slot (slot itvn 'it-value ) 'tv-sec ) val-secs
+ (slot (slot itvn 'it-value ) 'tv-usec) val-usec)
+ (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
+ (values t
+ (slot (slot itvo 'it-interval) 'tv-sec)
+ (slot (slot itvo 'it-interval) 'tv-usec)
+ (slot (slot itvo 'it-value) 'tv-sec)
+ (slot (slot itvo 'it-value) 'tv-usec))
+ which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
+
+\f
+;;; FIXME: Many Unix error code definitions were deleted from the old
+;;; CMU CL source code here, but not in the exports of SB-UNIX. I
+;;; (WHN) hope that someday I'll figure out an automatic way to detect
+;;; unused symbols in package exports, but if I don't, there are
+;;; enough of them all in one place here that they should probably be
+;;; removed by hand.
+\f
+(defconstant micro-seconds-per-internal-time-unit
+ (/ 1000000 sb!xc:internal-time-units-per-second))
+
+;;; UNIX specific code, that has been cleanly separated from the
+;;; Windows build.
+#!-win32
+(progn
+
+ #!-sb-fluid (declaim (inline get-time-of-day))
+ (defun get-time-of-day ()
+ "Return the number of seconds and microseconds since the beginning of
+the UNIX epoch (January 1st 1970.)"
+ #!+darwin
+ (with-alien ((tv (struct timeval)))
+ ;; CLH: FIXME! This seems to be a MacOS bug, but on x86-64/darwin,
+ ;; gettimeofday occasionally fails. passing in a null pointer for the
+ ;; timezone struct seems to work around the problem. NS notes: Darwin
+ ;; manpage says the timezone is not used anymore in their implementation
+ ;; at all.
+ (syscall* ("gettimeofday" (* (struct timeval))
+ (* (struct timezone)))
+ (values (slot tv 'tv-sec)
+ (slot tv 'tv-usec))
+ (addr tv)
+ nil))
+ #!-(and x86-64 darwin)
+ (with-alien ((tv (struct timeval))
+ (tz (struct timezone)))
+ (syscall* ("gettimeofday" (* (struct timeval))
+ (* (struct timezone)))
+ (values (slot tv 'tv-sec)
+ (slot tv 'tv-usec))
+ (addr tv)
+ (addr tz))))
+
+ (declaim (inline system-internal-run-time
+ system-real-time-values))
+
+ (defun system-real-time-values ()
+ (multiple-value-bind (sec usec) (get-time-of-day)
+ (declare (type (unsigned-byte 32) sec usec))
+ (values sec (truncate usec micro-seconds-per-internal-time-unit))))
+
+ ;; There are two optimizations here that actually matter (on 32-bit
+ ;; systems): substract the epoch from seconds and milliseconds
+ ;; separately, as those should remain fixnums for the first 17 years
+ ;; or so of runtime. Also, avoid doing consing a new bignum if the
+ ;; result would be = to the last result given.
+ ;;
+ ;; Note: the next trick would be to spin a separate thread to update
+ ;; a global value once per internal tick, so each individual call to
+ ;; get-internal-real-time would be just a memory read... but that is
+ ;; probably best left for user-level code. ;)
+ ;;
+ ;; Thanks to James Anderson for the optimization hint.
+ ;;
+ ;; Yes, it is possible to a computation to be GET-INTERNAL-REAL-TIME
+ ;; bound.
+ ;;
+ ;; --NS 2007-04-05
+ (let ((e-sec 0)
+ (e-msec 0)
+ (c-sec 0)
+ (c-msec 0)
+ (now 0))
+ (declare (type (unsigned-byte 32) e-sec c-sec)
+ (type fixnum e-msec c-msec)
+ (type unsigned-byte now))
+ (defun reinit-internal-real-time ()
+ (setf (values e-sec e-msec) (system-real-time-values)
+ c-sec 0
+ c-msec 0))
+ ;; If two threads call this at the same time, we're still safe, I
+ ;; believe, as long as NOW is updated before either of C-MSEC or
+ ;; C-SEC. Same applies to interrupts. --NS
+ ;;
+ ;; I believe this is almost correct with x86/x86-64 cache
+ ;; coherency, but if the new value of C-SEC, C-MSEC can become
+ ;; visible to another CPU without NOW doing the same then it's
+ ;; unsafe. It's `almost' correct on x86 because writes by other
+ ;; processors may become visible in any order provided transitity
+ ;; holds. With at least three cpus, C-MSEC and C-SEC may be from
+ ;; different threads and an incorrect value may be returned.
+ ;; Considering that this failure is not detectable by the caller -
+ ;; it looks like time passes a bit slowly - and that it should be
+ ;; an extremely rare occurance I'm inclinded to leave it as it is.
+ ;; --MG
+ (defun get-internal-real-time ()
+ (multiple-value-bind (sec msec) (system-real-time-values)
+ (unless (and (= msec c-msec) (= sec c-sec))
+ (setf now (+ (* (- sec e-sec)
+ sb!xc:internal-time-units-per-second)
+ (- msec e-msec))
+ c-msec msec
+ c-sec sec))
+ now)))
+
+ (defun system-internal-run-time ()
+ (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
+ (unix-fast-getrusage rusage_self)
+ (declare (ignore ignore)
+ (type (unsigned-byte 31) utime-sec stime-sec)
+ ;; (Classic CMU CL had these (MOD 1000000) instead, but
+ ;; at least in Linux 2.2.12, the type doesn't seem to
+ ;; be documented anywhere and the observed behavior is
+ ;; to sometimes return 1000000 exactly.)
+ (type (integer 0 1000000) utime-usec stime-usec))
+ (let ((result (+ (* (+ utime-sec stime-sec)
+ sb!xc:internal-time-units-per-second)
+ (floor (+ utime-usec
+ stime-usec
+ (floor micro-seconds-per-internal-time-unit 2))
+ micro-seconds-per-internal-time-unit))))
+ result))))
+\f
+;;; FIXME, KLUDGE: GET-TIME-OF-DAY used to be UNIX-GETTIMEOFDAY, and had a
+;;; primary return value indicating sucess, and also returned timezone
+;;; information -- though the timezone data was not there on Darwin.
+;;; Now we have GET-TIME-OF-DAY, but it turns out that despite SB-UNIX being
+;;; an implementation package UNIX-GETTIMEOFDAY has users in the wild.
+;;; So we're stuck with it for a while -- maybe delete it towards the end
+;;; of 2009.