From 9a82b26397de09d67372f34158090c2284fd1411 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 21 May 2009 15:27:37 +0000 Subject: [PATCH] 1.0.28.66: implement SB-EXT:GET-TIME-OF-DAY * On unixoid platforms is this pretty much what UNIX-GETTIMEOFDAY used to be, whereas on Windows we build it on top of SystemTimeAsFileTime since gettimeofday() doesn't give us microseconds there -- it's almost as if the POSIX API support on Windows as intentionally sucky... * Keep UNIX-GETTIMEOFDAY around as a wrapper to GET-TIME-OF-DAY, since there are applications in the wild that use it directly. Scheduled for deletion towards to the end of 2009, or so. --- NEWS | 2 ++ package-data-list.lisp-expr | 3 +- src/code/time.lisp | 4 +-- src/code/unix.lisp | 76 +++++++++++++++++++++++-------------------- src/code/win32.lisp | 45 +++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 92 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 4b3e1a9..a3dacf7 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,8 @@ :HASH-FUNCTION argument. Refer to user manual for details. * new feature: SB-EXT:DEFGLOBAL macro allows defining global non-special variables. + * new feature: SB-EXT:GET-TIME-OF-DAY provides access to seconds and + microseconds since the Unix epoch on all platforms. * new feature: SB-EXT:ALWAYS-BOUND proclamation inhibits MAKUNBOUND, and allows the compiler to safely elide boundedness checks for special variables. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 138f893..44e6e46 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -586,8 +586,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "COMPARE-AND-SWAP" "ATOMIC-INCF" - ;; Timing information + ;; Time related things "CALL-WITH-TIMING" + "GET-TIME-OF-DAY" ;; People have various good reasons to mess with the GC. "*AFTER-GC-HOOKS*" diff --git a/src/code/time.lisp b/src/code/time.lisp index 834f143..6cdb53d 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -95,9 +95,7 @@ Includes both \"system\" and \"user\" time." #!+sb-doc "Return a single integer for the current time of day in universal time format." - (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday) - (declare (ignore res)) - (+ secs unix-to-universal-time))) + (+ (get-time-of-day) unix-to-universal-time)) (defun get-decoded-time () #!+sb-doc diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 3abc1d1..fb70a51 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -838,39 +838,6 @@ corresponds to NAME, or NIL if there is none." (struct timezone (tz-minuteswest int) ; minutes west of Greenwich (tz-dsttime int))) ; type of dst correction - -;;; If it works, UNIX-GETTIMEOFDAY returns 5 values: T, the seconds -;;; and microseconds of the current time of day, the timezone (in -;;; minutes west of Greenwich), and a daylight-savings flag. If it -;;; doesn't work, it returns NIL and the errno. -#!-sb-fluid (declaim (inline unix-gettimeofday)) -(defun unix-gettimeofday () - #!+(and x86-64 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. I can't - ;; find any instances in the SBCL where we actually ues the - ;; timezone values, so we just punt for the moment. - (syscall* ("gettimeofday" (* (struct timeval)) - (* (struct timezone))) - (values t - (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 t - (slot tv 'tv-sec) - (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) - (addr tv) - (addr tz)))) ;; Type of the second argument to `getitimer' and @@ -956,12 +923,40 @@ corresponds to NAME, or NIL if there is none." ;;; 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 og +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) (unix-gettimeofday) - (declare (ignore _) (type (unsigned-byte 32) sec usec)) + (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 @@ -1036,6 +1031,17 @@ corresponds to NAME, or NIL if there is none." micro-seconds-per-internal-time-unit)))) result)))) +;;; 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. +(defun unix-gettimeofday () + (multiple-value-bind (sec usec) (get-time-of-day) + (values t sec usec nil nil))) + ;;;; opendir, readdir, closedir, and dirent-name (declaim (inline unix-opendir)) diff --git a/src/code/win32.lisp b/src/code/win32.lisp index facc8c9..fb3d5c1 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -530,6 +530,51 @@ (with-process-times (creation-time exit-time kernel-time user-time) (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit)))) +(define-alien-type hword (unsigned 16)) + +(define-alien-type systemtime + (struct systemtime + (year hword) + (month hword) + (weekday hword) + (day hword) + (hour hword) + (minute hword) + (second hword) + (millisecond hword))) + +;; Obtained with, but the XC can't deal with that -- but +;; it's not like the value is ever going to change... +;; (with-alien ((filetime filetime) +;; (epoch systemtime)) +;; (setf (slot epoch 'year) 1970 +;; (slot epoch 'month) 1 +;; (slot epoch 'day) 1 +;; (slot epoch 'hour) 0 +;; (slot epoch 'minute) 0 +;; (slot epoch 'second) 0 +;; (slot epoch 'millisecond) 0) +;; (syscall (("SystemTimeToFileTime" 8) void +;; (* systemtime) (* filetime)) +;; filetime +;; (addr epoch) +;; (addr filetime))) +(defconstant +unix-epoch-filetime+ 116444736000000000) + +#!-sb-fluid +(declaim (inline get-time-of-day)) +(defun get-time-of-day () + "Return the number of seconds and microseconds since the beginning og the +UNIX epoch: January 1st 1970." + (with-alien ((system-time filetime)) + (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime)) + (multiple-value-bind (sec 100ns) + (floor (- system-time +unix-epoch-filetime+) + (* 100ns-per-internal-time-unit + internal-time-units-per-second)) + (values sec (floor 100ns 10))) + (addr system-time)))) + ;; SETENV ;; The SetEnvironmentVariable function sets the contents of the specified ;; environment variable for the current process. diff --git a/version.lisp-expr b/version.lisp-expr index a8b2452..e8d9473 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.65" +"1.0.28.66" -- 1.7.10.4