From 2b90fd1dbad23322258222a2ef4cef7f6a00831d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 26 Oct 2006 08:38:49 +0000 Subject: [PATCH] 0.9.18.6: Win32 get-internal-real-time improved * The old version was accurate only to the second, new one gets milliseconds right. * Move unix/win32 implementation bodies of GET-INTERNAL-*-TIME to unix.lisp and win32.lisp (less conditionalization). * Move *GC-RUN-TIME* zeroing to GC-REINIT. * Initialize the system epoch to start time, not to time of first call to GET-INTERNAL-REAL-TIME, document system epoch in GET-INTERNAL-REAL-TIME. * Sort the stub function calls in src/runtime/win32.c nicely. --- NEWS | 3 ++ build-order.lisp-expr | 1 + package-data-list.lisp-expr | 6 ++- src/code/cold-init.lisp | 4 +- src/code/early-time.lisp | 18 +++++++ src/code/gc.lisp | 1 + src/code/time.lisp | 76 ++++++----------------------- src/code/unix.lisp | 37 ++++++++++++++ src/code/win32-os.lisp | 16 +++---- src/code/win32.lisp | 44 ++++++++++------- src/runtime/win32-os.c | 112 +++++++++++++++++-------------------------- version.lisp-expr | 2 +- 12 files changed, 160 insertions(+), 160 deletions(-) create mode 100755 src/code/early-time.lisp diff --git a/NEWS b/NEWS index a6b1a44..9b56030 100644 --- a/NEWS +++ b/NEWS @@ -2,9 +2,12 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18: * improvement: floating point modes in effect are now saved in core, and restored on startup. + * improvement: GET-INTERNAL-REAL-TIME now reports the time since + startup, not time since first call to GET-INTERNAL-REAL-TIME. * improvements to the Windows port: ** floating point exceptions are now reported correctly. ** stack exhaustion detection works partially. + ** more accurate GET-INTERNAL-REAL-TIME. changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.17: * enhancement: SB-POSIX now supports cfsetispeed(3), cfsetospeed(3), diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 6109208..8bed587 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -215,6 +215,7 @@ ("src/code/string" :not-host) ("src/code/mipsstrops" :not-host) + ("src/code/early-time" :not-host) ("src/code/unix" :not-host) #!+win32 ("src/code/win32" :not-host) #!+mach ("src/code/mach" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ec1aa1f..96dd458 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1592,6 +1592,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FLOAT-COLD-INIT-OR-REINIT" "GC-REINIT" + "TIME-REINIT" "SIGNAL-COLD-INIT-OR-REINIT" "STREAM-COLD-INIT-OR-RESET" @@ -1948,6 +1949,8 @@ SB-KERNEL) have been undone, but probably more remain." ;; FIXME: STRUCTURE!OBJECT stuff probably belongs in SB!KERNEL. "STRUCTURE!OBJECT" "STRUCTURE!OBJECT-MAKE-LOAD-FORM" "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" + "SYSTEM-INTERNAL-REAL-TIME" + "SYSTEM-INTERNAL-RUN-TIME" "UNDEFINED-FOREIGN-SYMBOLS-P" "UPDATE-LINKAGE-TABLE" "VECTOR-SAP" "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS" @@ -2382,5 +2385,4 @@ SBCL itself" "HANDLE-CLEAR-INPUT" "HANDLE-LISTEN" "INT-PTR" "INVALID-HANDLE" "MILLISLEEP" "PEEK-CONSOLE-INPUT" "PEEK-NAMED-PIPE" "READ-FILE" "WRITE-FILE" - - "GET-PROCESS-TIMES" "GET-VERSION-EX"))) + "WITH-PROCESS-TIMES" "GET-VERSION-EX"))) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 69e0541..6bb7b33 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -295,10 +295,8 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) (float-cold-init-or-reinit))) (gc-reinit) - ;; make sure TIME works correctly from saved cores - (setf *internal-real-time-base-seconds* nil) - (setf *gc-run-time* 0) (foreign-reinit) + (time-reinit) ;; If the debugger was disabled in the saved core, we need to ;; re-disable ldb again. (when (eq *invoke-debugger-hook* 'sb!debug::debugger-disabled-hook) diff --git a/src/code/early-time.lisp b/src/code/early-time.lisp new file mode 100755 index 0000000..05ee4e2 --- /dev/null +++ b/src/code/early-time.lisp @@ -0,0 +1,18 @@ +;;;; Time-related constants that are needed before unix.lisp / win32.lisp +;;;; can be built. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +(defconstant sb!xc:internal-time-units-per-second 1000 + #!+sb-doc + "The number of internal time units that fit into a second. See +GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 1a5abc7..7945c27 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -121,6 +121,7 @@ (gc-on) (gc) (setf *n-bytes-freed-or-purified* 0 + *gc-run-time* 0 ;; See comment in interr.lisp *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error))) diff --git a/src/code/time.lisp b/src/code/time.lisp index 0fc9d1c..9a6d825 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -11,73 +11,25 @@ (in-package "SB!IMPL") -(defconstant sb!xc:internal-time-units-per-second 1000 - #!+sb-doc - "The number of internal time units that fit into a second. See - GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") - -(defconstant micro-seconds-per-internal-time-unit - (/ 1000000 sb!xc:internal-time-units-per-second)) +;;; Internal epoch, used as base for real-time. +(declaim (unsigned-byte *internal-epoch*)) +(defvar *internal-epoch* 0) -(defconstant 100ns-per-internal-time-unit - (/ 10000000 internal-time-units-per-second)) - -;;; The base number of seconds for our internal "epoch". We initialize -;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and -;;; then subtract this out of the result. -(defvar *internal-real-time-base-seconds* nil) -(declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*)) +(defun time-reinit () + (setf *internal-epoch* (system-internal-real-time))) (defun get-internal-real-time () #!+sb-doc - "Return the real time in the internal time format. (See - INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time." - (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday) - (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) - (let ((base *internal-real-time-base-seconds*) - (uint (truncate useconds - micro-seconds-per-internal-time-unit))) - (declare (type (unsigned-byte 32) uint)) - (cond (base - (+ (* (- seconds base) - sb!xc:internal-time-units-per-second) - uint)) - (t - (setq *internal-real-time-base-seconds* seconds) - uint))))) + "Return the real time (\"wallclock time\") since startup in the internal +time format. (See INTERNAL-TIME-UNITS-PER-SECOND.)" + (- (system-internal-real-time) *internal-epoch*)) (defun get-internal-run-time () #!+sb-doc - "Return the run time in the internal time format. (See - INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage." - ;; FIXME: This is yet another creeping malaise: instead of #+/-win32 - ;; conditionals things like these need to be split into wholly separate - ;; implementations of get-internal-run-time, probably one in - ;; unix.lisp and one in win32.lisp -- that however requires also - ;; cleaning up unix.lisp sufficiently to remove it from the Windows build. - #-win32 - (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) - (sb!unix:unix-fast-getrusage sb!unix: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)) - #!+win32 - (multiple-value-bind - (creation-time exit-time kernel-time user-time) - (sb!win32:get-process-times) - (declare (ignore creation-time exit-time)) - (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit)))) + "Return the run time used by the process in the internal time format. (See +INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage. +Includes both \"system\" and \"user\" time." + (system-internal-run-time)) ;;;; Encode and decode universal times. @@ -145,8 +97,8 @@ (defun get-universal-time () #!+sb-doc - "Return a single integer for the current time of - day in universal time format." + "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))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 25336bf..40cfd07 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -1014,6 +1014,42 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." dst) (t (subseq dst 0 dst-len))))) + + +;;; UNIX specific code, that has been cleanly separated from the +;;; Windows build. +#!-win32 +(progn + (defconstant micro-seconds-per-internal-time-unit + (/ 1000000 sb!xc:internal-time-units-per-second)) + + (declaim (inline system-internal-real-time system-internal-run-time)) + (defun system-internal-real-time () + (multiple-value-bind (ignore seconds useconds) (unix-gettimeofday) + (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) + (let ((uint (truncate useconds + micro-seconds-per-internal-time-unit))) + (declare (type (unsigned-byte 32) uint)) + (+ (* seconds sb!xc:internal-time-units-per-second) + uint)))) + + (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)))) ;;;; A magic constant for wait3(). ;;;; @@ -1066,3 +1102,4 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(progn ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) + diff --git a/src/code/win32-os.lisp b/src/code/win32-os.lisp index 57bc68f..fa82edb 100644 --- a/src/code/win32-os.lisp +++ b/src/code/win32-os.lisp @@ -26,18 +26,18 @@ if not available." (or *software-version* (setf *software-version* - (multiple-value-bind (MajorVersion MinorVersion BuildNumber PlatformId CSDVersion) + (multiple-value-bind + (major-version minor-version build-number platform-id csd-version) (sb!win32:get-version-ex) - (declare (ignore PlatformId)) - (format nil (if (zerop (length CSDVersion)) "~A.~A.~A" "~A.~A.~A (~A)") - MajorVersion MinorVersion BuildNumber CSDVersion))))) + (declare (ignore platform-id)) + (format nil (if (zerop (length csd-version)) + "~A.~A.~A" + "~A.~A.~A (~A)") + major-version minor-version build-number csd-version))))) ;;; Return user time, system time, and number of page faults. (defun get-system-info () - ;; FIXME: number of page faults is always zero - (multiple-value-bind (creation-time exit-time kernel-time user-time) - (sb!win32:get-process-times) - (declare (ignore creation-time exit-time)) + (sb!win32:with-process-times (creation-time exit-time kernel-time user-time) (values (floor user-time 10) (floor kernel-time 10) 0))) ;;; Return the system page size. diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 5049c1e..3e55344 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -486,6 +486,9 @@ ;;;; Process time information +(defconstant 100ns-per-internal-time-unit + (/ 10000000 sb!xc:internal-time-units-per-second)) + ;; FILETIME ;; The FILETIME structure is a 64-bit value representing the number of ;; 100-nanosecond intervals since January 1, 1601 (UTC). @@ -493,22 +496,31 @@ ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp? (define-alien-type FILETIME (sb!alien:unsigned 64)) -(defun get-process-times () - (with-alien ((creation-time filetime) - (exit-time filetime) - (kernel-time filetime) - (user-time filetime)) - (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime) - (* filetime) (* filetime)) - (values creation-time - exit-time - kernel-time - user-time) - (get-current-process) - (addr creation-time) - (addr exit-time) - (addr kernel-time) - (addr user-time)))) +(defmacro with-process-times ((creation-time exit-time kernel-time user-time) + &body forms) + `(with-alien ((,creation-time filetime) + (,exit-time filetime) + (,kernel-time filetime) + (,user-time filetime)) + (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime) + (* filetime) (* filetime)) + (progn ,@forms) + (get-current-process) + (addr ,creation-time) + (addr ,exit-time) + (addr ,kernel-time) + (addr ,user-time)))) + +(declaim (inline system-internal-real-time system-internal-run-time)) +(defun system-internal-real-time () + (with-alien ((system-time filetime)) + (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime)) + (values (floor system-time 100ns-per-internal-time-unit)) + (addr system-time)))) + +(defun system-internal-run-time () + (with-process-times (creation-time exit-time kernel-time user-time) + (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit)))) ;; SETENV ;; The SetEnvironmentVariable function sets the contents of the specified diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index f43af0d..9f945e8 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -26,6 +26,7 @@ * yet. */ +#include #include #include #include @@ -629,87 +630,62 @@ char *dirname(char *path) void scratch(void) { - strerror(42); - asin(0); + CloseHandle(0); + FlushConsoleInputBuffer(0); + FormatMessageA(0, 0, 0, 0, 0, 0, 0); + FreeLibrary(0); + GetACP(); + GetConsoleCP(); + GetConsoleOutputCP(); + GetCurrentProcess(); + GetExitCodeProcess(0, 0); + GetLastError(); + GetOEMCP(); + GetProcAddress(0, 0); + GetProcessTimes(0, 0, 0, 0, 0); + GetSystemTimeAsFileTime(0); + LoadLibrary(0); + LocalFree(0); + PeekConsoleInput(0, 0, 0, 0); + PeekNamedPipe(0, 0, 0, 0, 0, 0); + ReadFile(0, 0, 0, 0, 0); + Sleep(0); + WriteFile(0, 0, 0, 0, 0); + _get_osfhandle(0); + _pipe(0,0,0); + access(0,0); acos(0); - sinh(0); + asin(0); + close(0); cosh(0); + dup(0); hypot(0, 0); + isatty(0); + sinh(0); + strerror(42); write(0, 0, 0); - close(0); - #ifndef LISP_FEATURE_SB_UNICODE - MoveFileA(0,0); - #else - MoveFileW(0,0); - #endif - #ifndef LISP_FEATURE_SB_UNICODE - GetCurrentDirectoryA(0,0); - #else - GetCurrentDirectoryW(0,0); - #endif - dup(0); - LoadLibrary(0); - GetProcAddress(0, 0); - FreeLibrary(0); #ifndef LISP_FEATURE_SB_UNICODE CreateDirectoryA(0,0); + GetComputerNameA(0, 0); + GetCurrentDirectoryA(0,0); + GetEnvironmentVariableA(0, 0, 0); + GetVersionExA(0); + MoveFileA(0,0); + SHGetFolderPathA(0, 0, 0, 0, 0); + SetCurrentDirectoryA(0); + SetEnvironmentVariableA(0, 0); #else CreateDirectoryW(0,0); - #endif - _pipe(0,0,0); - isatty(0); - access(0,0); - GetLastError(); - FormatMessageA(0, 0, 0, 0, 0, 0, 0); - #ifdef LISP_FEATURE_SB_UNICODE FormatMessageW(0, 0, 0, 0, 0, 0, 0); - #endif - _get_osfhandle(0); - ReadFile(0, 0, 0, 0, 0); - WriteFile(0, 0, 0, 0, 0); - PeekNamedPipe(0, 0, 0, 0, 0, 0); - FlushConsoleInputBuffer(0); - PeekConsoleInput(0, 0, 0, 0); - Sleep(0); - #ifndef LISP_FEATURE_SB_UNICODE - SHGetFolderPathA(0, 0, 0, 0, 0); - #else - SHGetFolderPathW(0, 0, 0, 0, 0); - #endif - GetACP(); - GetOEMCP(); - LocalFree(0); - #ifndef LISP_FEATURE_SB_UNICODE - GetEnvironmentVariableA(0, 0, 0); - #else + GetComputerNameW(0, 0); + GetCurrentDirectoryW(0,0); GetEnvironmentVariableW(0, 0, 0); - #endif - GetConsoleCP(); - GetConsoleOutputCP(); - GetExitCodeProcess(0, 0); - GetCurrentProcess(); - GetProcessTimes(0, 0, 0, 0, 0); - #ifndef LISP_FEATURE_SB_UNICODE - SetEnvironmentVariableA(0, 0); - #else - SetEnvironmentVariableW(0, 0); - #endif - #ifndef LISP_FEATURE_SB_UNICODE - GetVersionExA(0); - #else GetVersionExW(0); - #endif - #ifndef LISP_FEATURE_SB_UNICODE - GetComputerNameA(0, 0); - #else - GetComputerNameW(0, 0); - #endif - #ifndef LISP_FEATURE_SB_UNICODE - SetCurrentDirectoryA(0); - #else + MoveFileW(0,0); + SHGetFolderPathW(0, 0, 0, 0, 0); SetCurrentDirectoryW(0); + SetEnvironmentVariableW(0, 0); #endif - CloseHandle(0); } char * diff --git a/version.lisp-expr b/version.lisp-expr index 4040c5c..0209443 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".) -"0.9.18.5" +"0.9.18.6" -- 1.7.10.4