X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftime.lisp;h=e21101506b42eb4c73a57a18d04d6a98defff642;hb=23c0c48f562d7dc5d1615bf13cb831b46c91d106;hp=95fe90b95c1267b47499dcd6b17f64998ac47d6f;hpb=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git diff --git a/src/code/time.lisp b/src/code/time.lisp index 95fe90b..e211015 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -18,6 +18,9 @@ (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) + +(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 @@ -32,41 +35,49 @@ (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))) + (uint (truncate useconds + micro-seconds-per-internal-time-unit))) (declare (type (unsigned-byte 32) uint)) (cond (base - (truly-the (unsigned-byte 32) - (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (- seconds base)) - sb!xc:internal-time-units-per-second)) - uint))) - (t - (setq *internal-real-time-base-seconds* seconds) - uint))))) + (+ (* (- seconds base) + sb!xc:internal-time-units-per-second) + uint)) + (t + (setq *internal-real-time-base-seconds* seconds) + uint))))) (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." - (declare (values (unsigned-byte 32))) + ;; 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 (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (+ 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))) + (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)))) ;;;; Encode and decode universal times. @@ -106,6 +117,18 @@ ;;; history (Perq time base?) could be cleaned up any on this basis. ;;; -- dan, 2003-08-08 +;;; In order to accomodate universal times between January 1st 1900 +;;; and sometime on December 13th 1901, I'm doing the same calculation +;;; as described above in order to handle dates in that interval, by +;;; normalizing them to March 1st 1903, which shares the same special +;;; properties described above (except for the 400-year property, but +;;; this isn't an issue for the limited range we need to handle). + +;;; One open issue is whether to pass UNIX a 64-bit time_t value on +;;; 64-bit platforms. I don't know if time_t is always 64-bit on those +;;; platforms, and looking at this file reveals a scary amount of +;;; literal 31 and 32s. +;;; -- bem, 2005-08-09 ;;; Subtract from the returned Internal-Time to get the universal ;;; time. The offset between our time base and the Perq one is 2145 @@ -138,19 +161,21 @@ (defconstant +mar-1-2000+ #.(encode-universal-time 0 0 0 1 3 2000 0)) (defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0)) +(defconstant +mar-1-1903+ #.(encode-universal-time 0 0 0 1 3 1903 0)) + (defun years-since-mar-2000 (utime) - "Returns number of complete years since March 1st 2000, and remainder in seconds" + "Returns number of complete years since March 1st 2000, and remainder in seconds" (let* ((days-in-year (* 86400 365)) - (days-in-4year (+ (* 4 days-in-year) 86400)) - (days-in-100year (- (* 25 days-in-4year) 86400)) - (days-in-400year (+ (* 4 days-in-100year) 86400)) - (offset (- utime +mar-1-2000+)) - (year 0)) + (days-in-4year (+ (* 4 days-in-year) 86400)) + (days-in-100year (- (* 25 days-in-4year) 86400)) + (days-in-400year (+ (* 4 days-in-100year) 86400)) + (offset (- utime +mar-1-2000+)) + (year 0)) (labels ((whole-num (x y inc max) - (let ((w (truncate x y))) - (when (and max (> w max)) (setf w max)) - (incf year (* w inc)) - (* w y)))) + (let ((w (truncate x y))) + (when (and max (> w max)) (setf w max)) + (incf year (* w inc)) + (* w y)))) (decf offset (whole-num offset days-in-400year 400 nil)) (decf offset (whole-num offset days-in-100year 100 3)) (decf offset (whole-num offset days-in-4year 4 25)) @@ -159,12 +184,17 @@ (defun truncate-to-unix-range (utime) (let ((unix-time (- utime unix-to-universal-time))) - (if (< unix-time (ash 1 31)) - unix-time - (multiple-value-bind (year offset) (years-since-mar-2000 utime) - (declare (ignore year)) - (+ +mar-1-2035+ (- unix-to-universal-time) offset))))) - + (cond + ((< unix-time (- (ash 1 31))) + (multiple-value-bind (year offset) (years-since-mar-2000 utime) + (declare (ignore year)) + (+ +mar-1-1903+ (- unix-to-universal-time) offset))) + ((>= unix-time (ash 1 31)) + (multiple-value-bind (year offset) (years-since-mar-2000 utime) + (declare (ignore year)) + (+ +mar-1-2035+ (- unix-to-universal-time) offset))) + (t unix-time)))) + (defun decode-universal-time (universal-time &optional time-zone) #!+sb-doc "Converts a universal-time to decoded time format returning the following @@ -173,117 +203,109 @@ Completely ignores daylight-savings-time when time-zone is supplied." (multiple-value-bind (daylight seconds-west) (if time-zone - (values nil (* time-zone 60 60)) - (multiple-value-bind (ignore seconds-west daylight) - (sb!unix::get-timezone (truncate-to-unix-range universal-time)) - (declare (ignore ignore)) - (declare (fixnum seconds-west)) - (values daylight seconds-west))) + (values nil (* time-zone 60 60)) + (multiple-value-bind (ignore seconds-west daylight) + (sb!unix::get-timezone (truncate-to-unix-range universal-time)) + (declare (ignore ignore)) + (declare (fixnum seconds-west)) + (values daylight seconds-west))) (declare (fixnum seconds-west)) (multiple-value-bind (weeks secs) - (truncate (+ (- universal-time seconds-west) seconds-offset) - seconds-in-week) + (truncate (+ (- universal-time seconds-west) seconds-offset) + seconds-in-week) (let ((weeks (+ weeks weeks-offset))) - (multiple-value-bind (t1 second) - (truncate secs 60) - (let ((tday (truncate t1 minutes-per-day))) - (multiple-value-bind (hour minute) - (truncate (- t1 (* tday minutes-per-day)) 60) - (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) - (tcent (truncate t2 quarter-days-per-century))) - (setq t2 (mod t2 quarter-days-per-century)) - (setq t2 (+ (- t2 (mod t2 4)) 3)) - (let* ((year (+ (* tcent 100) - (truncate t2 quarter-days-per-year))) - (days-since-mar0 - (1+ (truncate (mod t2 quarter-days-per-year) 4))) - (day (mod (+ tday weekday-november-17-1858) 7)) - (t3 (+ (* days-since-mar0 5) 456))) - (cond ((>= t3 1989) - (setq t3 (- t3 1836)) - (setq year (1+ year)))) - (multiple-value-bind (month t3) - (truncate t3 153) - (let ((date (1+ (truncate t3 5)))) - (values second minute hour date month year day - daylight - (if daylight - (1+ (/ seconds-west 60 60)) - (/ seconds-west 60 60)))))))))))))) + (multiple-value-bind (t1 second) + (truncate secs 60) + (let ((tday (truncate t1 minutes-per-day))) + (multiple-value-bind (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (let* ((year (+ (* tcent 100) + (truncate t2 quarter-days-per-year))) + (days-since-mar0 + (1+ (truncate (mod t2 quarter-days-per-year) 4))) + (day (mod (+ tday weekday-november-17-1858) 7)) + (t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-bind (month t3) + (truncate t3 153) + (let ((date (1+ (truncate t3 5)))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ seconds-west 60 60)) + (/ seconds-west 60 60)))))))))))))) (defun pick-obvious-year (year) (declare (type (mod 100) year)) (let* ((current-year (nth-value 5 (get-decoded-time))) - (guess (+ year (* (truncate (- current-year 50) 100) 100)))) + (guess (+ year (* (truncate (- current-year 50) 100) 100)))) (declare (type (integer 1900 9999) current-year guess)) (if (> (- current-year guess) 50) - (+ guess 100) - guess))) + (+ guess 100) + guess))) (defun leap-years-before (year) (let ((years (- year 1901))) (+ (- (truncate years 4) - (truncate years 100)) + (truncate years 100)) (truncate (+ years 300) 400)))) (defvar *days-before-month* #.(let ((reversed-result nil) - (sum 0)) + (sum 0)) (push nil reversed-result) (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31)) - (push sum reversed-result) - (incf sum days-in-month)) + (push sum reversed-result) + (incf sum days-in-month)) (coerce (nreverse reversed-result) 'simple-vector))) - + (defun encode-universal-time (second minute hour date month year - &optional time-zone) + &optional time-zone) #!+sb-doc "The time values specified in decoded format are converted to universal time, which is returned." (declare (type (mod 60) second) - (type (mod 60) minute) - (type (mod 24) hour) - (type (integer 1 31) date) - (type (integer 1 12) month) - (type (or (integer 0 99) (integer 1900)) year) - (type (or null rational) time-zone)) + (type (mod 60) minute) + (type (mod 24) hour) + (type (integer 1 31) date) + (type (integer 1 12) month) + (type (or (integer 0 99) (integer 1899)) year) + ;; that type used to say (integer 1900), but that's + ;; incorrect when a time-zone is specified: we should be + ;; able to encode to produce 0 when a non-zero timezone is + ;; specified - bem, 2005-08-09 + (type (or null rational) time-zone)) (let* ((year (if (< year 100) - (pick-obvious-year year) - year)) - (days (+ (1- date) - (aref *days-before-month* month) - (if (> month 2) - (leap-years-before (1+ year)) - (leap-years-before year)) - (* (- year 1900) 365))) - (hours (+ hour (* days 24)))) + (pick-obvious-year year) + year)) + (days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24))) + (encoded-time 0)) (if time-zone - (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) - ;; can't ask unix for times after 2037: this is only a problem - ;; if we need to query the system timezone - (if (> year 2037) - (labels ((leap-year-p (year) - (cond ((zerop (mod year 400)) t) - ((zerop (mod year 100)) nil) - ((zerop (mod year 4)) t) - (t nil)))) - (let* ((fake-year (if (leap-year-p year) 2036 2037)) - (fake-time (encode-universal-time second minute hour - date month fake-year))) - (+ fake-time - (* 86400 (+ (* 365 (- year fake-year)) - (- (leap-years-before year) - (leap-years-before fake-year))))))) - (let* ((secwest-guess - (sb!unix::unix-get-seconds-west - (- (* hours 60 60) unix-to-universal-time))) - (guess (+ second (* 60 (+ minute (* hours 60))) - secwest-guess)) - (secwest - (sb!unix::unix-get-seconds-west - (- guess unix-to-universal-time)))) - (+ guess (- secwest secwest-guess))))))) + (setf encoded-time (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))) + (let* ((secwest-guess + (sb!unix::unix-get-seconds-west + (truncate-to-unix-range (* hours 60 60)))) + (guess (+ second (* 60 (+ minute (* hours 60))) + secwest-guess)) + (secwest + (sb!unix::unix-get-seconds-west + (truncate-to-unix-range guess)))) + (setf encoded-time (+ guess (- secwest secwest-guess))))) + (assert (typep encoded-time '(integer 0))) + encoded-time)) ;;;; TIME @@ -308,30 +330,30 @@ (defun %time (fun) (declare (type function fun)) (let (old-run-utime - new-run-utime - old-run-stime - new-run-stime - old-real-time - new-real-time - old-page-faults - new-page-faults - real-time-overhead - run-utime-overhead - run-stime-overhead - page-faults-overhead - old-bytes-consed - new-bytes-consed - cons-overhead) + new-run-utime + old-run-stime + new-run-stime + old-real-time + new-real-time + old-page-faults + new-page-faults + real-time-overhead + run-utime-overhead + run-stime-overhead + page-faults-overhead + old-bytes-consed + new-bytes-consed + cons-overhead) ;; Calculate the overhead... (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) ;; Do it a second time to make sure everything is faulted in. (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (new-run-utime new-run-stime new-page-faults new-bytes-consed) (time-get-sys-info)) (setq run-utime-overhead (- new-run-utime old-run-utime)) (setq run-stime-overhead (- new-run-stime old-run-stime)) @@ -343,33 +365,33 @@ (setq cons-overhead (- new-bytes-consed old-bytes-consed)) ;; Now get the initial times. (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (setq old-real-time (get-internal-real-time)) (let ((start-gc-run-time *gc-run-time*)) - (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) - (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))) - (format *trace-output* - "~&Evaluation took:~% ~ - ~S second~:P of real time~% ~ - ~S second~:P of user run time~% ~ - ~S second~:P of system run time~% ~ -~@[ [Run times include ~S second~:P GC run time.]~% ~]~ - ~S page fault~:P and~% ~ - ~S bytes consed.~%" - (max (/ (- new-real-time old-real-time) - (float sb!xc:internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) - (unless (zerop gc-run-time) - (/ (float gc-run-time) - (float sb!xc:internal-time-units-per-second))) - (max (- new-page-faults old-page-faults) 0) - (max (- new-bytes-consed old-bytes-consed) 0))))))) + (multiple-value-prog1 + ;; Execute the form and return its values. + (funcall fun) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) + (setq new-real-time (- (get-internal-real-time) real-time-overhead)) + (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))) + (format *trace-output* + "~&Evaluation took:~% ~ + ~S second~:P of real time~% ~ + ~S second~:P of user run time~% ~ + ~S second~:P of system run time~% ~ + ~@[[Run times include ~S second~:P GC run time.]~% ~]~ + ~S page fault~:P and~% ~ + ~:D bytes consed.~%" + (max (/ (- new-real-time old-real-time) + (float sb!xc:internal-time-units-per-second)) + 0.0) + (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) + (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) + (unless (zerop gc-run-time) + (/ (float gc-run-time) + (float sb!xc:internal-time-units-per-second))) + (max (- new-page-faults old-page-faults) 0) + (max (- new-bytes-consed old-bytes-consed) 0)))))))