1;;;; low-level time functions 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!IMPL") 13 14(defun time-reinit () 15 (reinit-internal-real-time)) 16 17;;; Implemented in unix.lisp and win32.lisp. 18#!+sb-doc 19(setf (fdocumentation 'get-internal-real-time 'function) 20 "Return the real time (\"wallclock time\") since startup in the internal 21time format. (See INTERNAL-TIME-UNITS-PER-SECOND.)") 22 23(defun get-internal-run-time () 24 #!+sb-doc 25 "Return the run time used by the process in the internal time format. (See 26INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage. 27Includes both \"system\" and \"user\" time." 28 (system-internal-run-time)) 29 30;;;; Encode and decode universal times. 31 32;;; In August 2003, work was done in this file for more plausible 33;;; timezone handling after the unix timezone database runs out in 34;;; 2038. We assume that timezone rules are trending sane rather than 35;;; insane, so for all years after the end of time_t we apply the 36;;; rules for 2035/2036 instead of the actual date asked for. Making 37;;; the same assumption about the early 1900s would be less 38;;; reasonable, however, so please note that we're still broken for 39;;; local time between 1900-1-1 and 1901-12-13 40 41;;; It should be noted that 64 bit machines don't actually fix this 42;;; problem, at least as of 2003, because the Unix zonefiles are 43;;; specified in terms of 32 bit fields even on, say, the Alpha. So, 44;;; references to the range of time_t elsewhere in this file should 45;;; rightly be read as shorthand for the range of an signed 32 bit 46;;; number of seconds since 1970-01-01 47 48;;; I'm obliged to Erik Naggum's "Long, Painful History of Time" paper 49;;; <http://naggum.no/lugm-time.html> for the choice of epoch here. 50;;; By starting the year in March, we avoid having to test the month 51;;; whenever deciding whether to account for a leap day. 2000 is 52;;; especially special, because it's divisible by 400, hence the start 53;;; of a 400 year leap year cycle 54 55;;; If a universal-time is after time_t runs out, we find its offset 56;;; from 1st March of whichever year it falls in, then add that to 57;;; 2035-3-1. This date has two relevant properties: (1) somewhere 58;;; near the end of time_t, and (2) preceding a leap year. Thus a 59;;; date which is e.g. 365.5 days from March 1st in its year will be 60;;; treated for timezone lookup as if it were Feb 29th 2036 61 62;;; This epoch is used only for fixing the timezones-outside-time_t 63;;; problem. Someday it would be nice to come back to this code and 64;;; see if the rest of the file and its references to Spice Lisp 65;;; history (Perq time base?) could be cleaned up any on this basis. 66;;; -- dan, 2003-08-08 67 68;;; In order to accomodate universal times between January 1st 1900 69;;; and sometime on December 13th 1901, I'm doing the same calculation 70;;; as described above in order to handle dates in that interval, by 71;;; normalizing them to March 1st 1903, which shares the same special 72;;; properties described above (except for the 400-year property, but 73;;; this isn't an issue for the limited range we need to handle). 74 75;;; One open issue is whether to pass UNIX a 64-bit time_t value on 76;;; 64-bit platforms. I don't know if time_t is always 64-bit on those 77;;; platforms, and looking at this file reveals a scary amount of 78;;; literal 31 and 32s. 79;;; -- bem, 2005-08-09 80 81;;; Subtract from the returned Internal-Time to get the universal 82;;; time. The offset between our time base and the Perq one is 2145 83;;; weeks and five days. 84(defconstant seconds-in-week (* 60 60 24 7)) 85(defconstant weeks-offset 2145) 86(defconstant seconds-offset 432000) 87(defconstant minutes-per-day (* 24 60)) 88(defconstant quarter-days-per-year (1+ (* 365 4))) 89(defconstant quarter-days-per-century 146097) 90(defconstant november-17-1858 678882) 91(defconstant weekday-november-17-1858 2) 92(defconstant unix-to-universal-time 2208988800) 93 94(defun get-universal-time () 95 #!+sb-doc 96 "Return a single integer for the current time of day in universal time 97format." 98 (+ (get-time-of-day) unix-to-universal-time)) 99 100(defun get-decoded-time () 101 #!+sb-doc 102 "Return nine values specifying the current time as follows: 103 second, minute, hour, date, month, year, day of week (0 = Monday), T 104 (daylight savings times) or NIL (standard time), and timezone." 105 (decode-universal-time (get-universal-time))) 106 107(defconstant +mar-1-2000+ #.(encode-universal-time 0 0 0 1 3 2000 0)) 108(defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0)) 109 110(defconstant +mar-1-1903+ #.(encode-universal-time 0 0 0 1 3 1903 0)) 111 112(defun years-since-mar-2000 (utime) 113 #!+sb-doc 114 "Returns number of complete years since March 1st 2000, and remainder in seconds" 115 (let* ((days-in-year (* 86400 365)) 116 (days-in-4year (+ (* 4 days-in-year) 86400)) 117 (days-in-100year (- (* 25 days-in-4year) 86400)) 118 (days-in-400year (+ (* 4 days-in-100year) 86400)) 119 (offset (- utime +mar-1-2000+)) 120 (year 0)) 121 (labels ((whole-num (x y inc max) 122 (let ((w (truncate x y))) 123 (when (and max (> w max)) (setf w max)) 124 (incf year (* w inc)) 125 (* w y)))) 126 (decf offset (whole-num offset days-in-400year 400 nil)) 127 (decf offset (whole-num offset days-in-100year 100 3)) 128 (decf offset (whole-num offset days-in-4year 4 25)) 129 (decf offset (whole-num offset days-in-year 1 3)) 130 (values year offset)))) 131 132(defun truncate-to-unix-range (utime) 133 (let ((unix-time (- utime unix-to-universal-time))) 134 (cond 135 ((< unix-time (- (ash 1 31))) 136 (multiple-value-bind (year offset) (years-since-mar-2000 utime) 137 (declare (ignore year)) 138 (+ +mar-1-1903+ (- unix-to-universal-time) offset))) 139 ((>= unix-time (ash 1 31)) 140 (multiple-value-bind (year offset) (years-since-mar-2000 utime) 141 (declare (ignore year)) 142 (+ +mar-1-2035+ (- unix-to-universal-time) offset))) 143 (t unix-time)))) 144 145(defun decode-universal-time (universal-time &optional time-zone) 146 #!+sb-doc 147 "Converts a universal-time to decoded time format returning the following 148 nine values: second, minute, hour, date, month, year, day of week (0 = 149 Monday), T (daylight savings time) or NIL (standard time), and timezone. 150 Completely ignores daylight-savings-time when time-zone is supplied." 151 (multiple-value-bind (seconds-west daylight) 152 (if time-zone 153 (values (* time-zone 60 60) nil) 154 (sb!unix::get-timezone (truncate-to-unix-range universal-time))) 155 (declare (fixnum seconds-west)) 156 (multiple-value-bind (weeks secs) 157 (truncate (+ (- universal-time seconds-west) seconds-offset) 158 seconds-in-week) 159 (let ((weeks (+ weeks weeks-offset))) 160 (multiple-value-bind (t1 second) 161 (truncate secs 60) 162 (let ((tday (truncate t1 minutes-per-day))) 163 (multiple-value-bind (hour minute) 164 (truncate (- t1 (* tday minutes-per-day)) 60) 165 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) 166 (tcent (truncate t2 quarter-days-per-century))) 167 (setq t2 (mod t2 quarter-days-per-century)) 168 (setq t2 (+ (- t2 (mod t2 4)) 3)) 169 (let* ((year (+ (* tcent 100) 170 (truncate t2 quarter-days-per-year))) 171 (days-since-mar0 172 (1+ (truncate (mod t2 quarter-days-per-year) 4))) 173 (day (mod (+ tday weekday-november-17-1858) 7)) 174 (t3 (+ (* days-since-mar0 5) 456))) 175 (cond ((>= t3 1989) 176 (setq t3 (- t3 1836)) 177 (setq year (1+ year)))) 178 (multiple-value-bind (month t3) 179 (truncate t3 153) 180 (let ((date (1+ (truncate t3 5)))) 181 (values second minute hour date month year day 182 daylight 183 (if daylight 184 (1+ (/ seconds-west 60 60)) 185 (/ seconds-west 60 60)))))))))))))) 186 187(defun pick-obvious-year (year) 188 (declare (type (mod 100) year)) 189 (let* ((current-year (nth-value 5 (get-decoded-time))) 190 (guess (+ year (* (truncate (- current-year 50) 100) 100)))) 191 (declare (type (integer 1900 9999) current-year guess)) 192 (if (> (- current-year guess) 50) 193 (+ guess 100) 194 guess))) 195 196(defun leap-years-before (year) 197 (let ((years (- year 1901))) 198 (+ (- (truncate years 4) 199 (truncate years 100)) 200 (truncate (+ years 300) 400)))) 201 202(defglobal **days-before-month** 203 #.(let ((reversed-result nil) 204 (sum 0)) 205 (push nil reversed-result) 206 (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31)) 207 (push sum reversed-result) 208 (incf sum days-in-month)) 209 (coerce (nreverse reversed-result) 'simple-vector))) 210 211(declaim (type (simple-vector 13) **days-before-month**)) 212 213(defun encode-universal-time (second minute hour date month year 214 &optional time-zone) 215 #!+sb-doc 216 "The time values specified in decoded format are converted to 217 universal time, which is returned." 218 (declare (type (mod 60) second) 219 (type (mod 60) minute) 220 (type (mod 24) hour) 221 (type (integer 1 31) date) 222 (type (integer 1 12) month) 223 (type (or (integer 0 99) (integer 1899)) year) 224 ;; that type used to say (integer 1900), but that's 225 ;; incorrect when a time-zone is specified: we should be 226 ;; able to encode to produce 0 when a non-zero timezone is 227 ;; specified - bem, 2005-08-09 228 (type (or null rational) time-zone)) 229 (let* ((year (if (< year 100) 230 (pick-obvious-year year) 231 year)) 232 (days (+ (1- date) 233 (truly-the (mod 335) 234 (svref **days-before-month** month)) 235 (if (> month 2) 236 (leap-years-before (1+ year)) 237 (leap-years-before year)) 238 (* (- year 1900) 365))) 239 (hours (+ hour (* days 24))) 240 (encoded-time 0)) 241 (if time-zone 242 (setf encoded-time (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))) 243 (let* ((secwest-guess 244 (sb!unix::get-timezone 245 (truncate-to-unix-range (* hours 60 60)))) 246 (guess (+ second (* 60 (+ minute (* hours 60))) 247 secwest-guess)) 248 (secwest 249 (sb!unix::get-timezone 250 (truncate-to-unix-range guess)))) 251 (setf encoded-time (+ guess (- secwest secwest-guess))))) 252 (assert (typep encoded-time '(integer 0))) 253 encoded-time)) 254 255;;;; TIME 256 257(defvar *gc-run-time* 0 258 #!+sb-doc 259 "Total CPU time spent doing garbage collection (as reported by 260GET-INTERNAL-RUN-TIME.) Initialized to zero on startup. It is safe to bind 261this to zero in order to measure GC time inside a certain section of code, but 262doing so may interfere with results reported by eg. TIME.") 263(declaim (type index *gc-run-time*)) 264 265(defun print-time (&key real-time-ms user-run-time-us system-run-time-us 266 gc-run-time-ms processor-cycles eval-calls 267 lambdas-converted page-faults bytes-consed 268 aborted) 269 (let ((total-run-time-us (+ user-run-time-us system-run-time-us))) 270 (format *trace-output* 271 "~&Evaluation took:~%~ 272 ~@< ~@;~/sb-impl::format-milliseconds/ of real time~%~ 273 ~/sb-impl::format-microseconds/ of total run time ~ 274 (~@/sb-impl::format-microseconds/ user, ~@/sb-impl::format-microseconds/ system)~%~ 275 ~[[ Run times consist of ~/sb-impl::format-milliseconds/ GC time, ~ 276 and ~/sb-impl::format-milliseconds/ non-GC time. ]~%~;~2*~]~ 277 ~,2F% CPU~%~ 278 ~@[~:D form~:P interpreted~%~]~ 279 ~@[~:D lambda~:P converted~%~]~ 280 ~@[~:D processor cycles~%~]~ 281 ~@[~:D page fault~:P~%~]~ 282 ~:D bytes consed~%~ 283 ~@[~%before it was aborted by a non-local transfer of control.~%~]~:>~%" 284 real-time-ms 285 total-run-time-us 286 user-run-time-us 287 system-run-time-us 288 (if (zerop gc-run-time-ms) 1 0) 289 gc-run-time-ms 290 ;; Round up so we don't mislead by saying 0.0 seconds of non-GC time... 291 (- (ceiling total-run-time-us 1000) gc-run-time-ms) 292 (if (zerop real-time-ms) 293 100.0 294 (float (* 100 (/ (round total-run-time-us 1000) real-time-ms)))) 295 eval-calls 296 lambdas-converted 297 processor-cycles 298 page-faults 299 bytes-consed 300 aborted))) 301 302(defmacro time (form) 303 #!+sb-doc 304 "Execute FORM and print timing information on *TRACE-OUTPUT*. 305 306On some hardware platforms estimated processor cycle counts are 307included in this output; this number is slightly inflated, since it 308includes the pipeline involved in reading the cycle counter -- 309executing \(TIME NIL) a few times will give you an idea of the 310overhead, and its variance. The cycle counters are also per processor, 311not per thread: if multiple threads are running on the same processor, 312the reported counts will include cycles taken up by all threads 313running on the processor where TIME was executed. Furthermore, if the 314operating system migrates the thread to another processor between 315reads of the cycle counter, the results will be completely bogus. 316Finally, the counter is cycle counter, incremented by the hardware 317even when the process is halted -- which is to say that cycles pass 318normally during operations like SLEEP." 319 `(call-with-timing #'print-time (lambda () ,form))) 320 321;;; Return all the data that we want TIME to report. 322(defun time-get-sys-info () 323 (multiple-value-bind (user sys faults) (sb!sys:get-system-info) 324 (values user sys faults (get-bytes-consed)))) 325 326(defun elapsed-cycles (h0 l0 h1 l1) 327 (declare (ignorable h0 l0 h1 l1)) 328 #!+cycle-counter 329 (+ (ash (- h1 h0) 32) 330 (- l1 l0)) 331 #!-cycle-counter 332 nil) 333(declaim (inline read-cycle-counter)) 334(defun read-cycle-counter () 335 #!+cycle-counter 336 (sb!vm::%read-cycle-counter) 337 #!-cycle-counter 338 (values 0 0)) 339 340;;; This is so that we don't have to worry about the vagaries of 341;;; floating point printing, or about conversions to floats dropping 342;;; or introducing decimals, which are liable to imply wrong precision. 343(defun format-microseconds (stream usec &optional colonp atp) 344 (declare (ignore colonp)) 345 (%format-decimal stream usec 6) 346 (unless atp 347 (write-string " seconds" stream))) 348 349(defun format-milliseconds (stream usec &optional colonp atp) 350 (declare (ignore colonp)) 351 (%format-decimal stream usec 3) 352 (unless atp 353 (write-string " seconds" stream))) 354 355(defun %format-decimal (stream number power) 356 (declare (stream stream) 357 (integer number power)) 358 (when (minusp number) 359 (write-char #\- stream) 360 (setf number (- number))) 361 (let ((scale (expt 10 power))) 362 (labels ((%fraction (fraction) 363 (if (zerop fraction) 364 (%zeroes) 365 (let ((scaled (* 10 fraction))) 366 (loop while (< scaled scale) 367 do (write-char #\0 stream) 368 (setf scaled (* scaled 10))))) 369 (format stream "~D" fraction)) 370 (%zeroes () 371 (let ((scaled (/ scale 10))) 372 (write-char #\0 stream) 373 (loop while (> scaled 1) 374 do (write-char #\0 stream) 375 (setf scaled (/ scaled 10)))))) 376 (cond ((zerop number) 377 (write-string "0." stream) 378 (%zeroes)) 379 ((< number scale) 380 (write-string "0." stream) 381 (%fraction number)) 382 ((= number scale) 383 (write-string "1." stream) 384 (%zeroes)) 385 ((> number scale) 386 (multiple-value-bind (whole fraction) (floor number scale) 387 (format stream "~D." whole) 388 (%fraction fraction)))))) 389 nil) 390 391;;; The guts of the TIME macro. Compute overheads, run the (compiled) 392;;; function, report the times. 393(defun call-with-timing (timer function &rest arguments) 394 #!+sb-doc 395 "Calls FUNCTION with ARGUMENTS, and gathers timing information about it. 396Then calls TIMER with keyword arguments describing the information collected. 397Calls TIMER even if FUNCTION performs a non-local transfer of control. Finally 398returns values returned by FUNCTION. 399 400 :USER-RUN-TIME-US 401 User run time in microseconds. 402 403 :SYSTEM-RUN-TIME-US 404 System run time in microseconds. 405 406 :REAL-TIME-MS 407 Real time in milliseconds. 408 409 :GC-RUN-TIME-MS 410 GC run time in milliseconds (included in user and system run time.) 411 412 :PROCESSOR-CYCLES 413 Approximate number of processor cycles used. (Omitted if not supported on 414 the platform -- currently available on x86 and x86-64 only.) 415 416 :EVAL-CALLS 417 Number of calls to EVAL. (Omitted if zero.) 418 419 :LAMBDAS-CONVERTED 420 Number of lambdas converted. (Omitted if zero.) 421 422 :PAGE-FAULTS 423 Number of page faults. (Omitted if zero.) 424 425 :BYTES-CONSED 426 Approximate number of bytes consed. 427 428 :ABORTED 429 True if FUNCTION caused a non-local transfer of control. (Omitted if 430 NIL.) 431 432EXPERIMENTAL: Interface subject to change." 433 (let (old-run-utime 434 new-run-utime 435 old-run-stime 436 new-run-stime 437 old-real-time 438 new-real-time 439 old-page-faults 440 new-page-faults 441 real-time-overhead 442 run-utime-overhead 443 run-stime-overhead 444 page-faults-overhead 445 old-bytes-consed 446 new-bytes-consed 447 cons-overhead 448 (fun (if (functionp function) function (fdefinition function)))) 449 (declare (function fun)) 450 ;; Calculate the overhead... 451 (multiple-value-setq 452 (old-run-utime old-run-stime old-page-faults old-bytes-consed) 453 (time-get-sys-info)) 454 ;; Do it a second time to make sure everything is faulted in. 455 (multiple-value-setq 456 (old-run-utime old-run-stime old-page-faults old-bytes-consed) 457 (time-get-sys-info)) 458 (multiple-value-setq 459 (new-run-utime new-run-stime new-page-faults new-bytes-consed) 460 (time-get-sys-info)) 461 (setq run-utime-overhead (- new-run-utime old-run-utime)) 462 (setq run-stime-overhead (- new-run-stime old-run-stime)) 463 (setq page-faults-overhead (- new-page-faults old-page-faults)) 464 (setq old-real-time (get-internal-real-time)) 465 (setq old-real-time (get-internal-real-time)) 466 (setq new-real-time (get-internal-real-time)) 467 (setq real-time-overhead (- new-real-time old-real-time)) 468 (setq cons-overhead (- new-bytes-consed old-bytes-consed)) 469 ;; Now get the initial times. 470 (multiple-value-setq 471 (old-run-utime old-run-stime old-page-faults old-bytes-consed) 472 (time-get-sys-info)) 473 (setq old-real-time (get-internal-real-time)) 474 (let ((start-gc-internal-run-time *gc-run-time*) 475 (*eval-calls* 0) 476 (sb!c::*lambda-conversions* 0) 477 (aborted t)) 478 (declare (special *eval-calls* sb!c::*lambda-conversions*)) 479 (multiple-value-bind (h0 l0) (read-cycle-counter) 480 (unwind-protect 481 (multiple-value-prog1 (apply fun arguments) 482 (setf aborted nil)) 483 (multiple-value-bind (h1 l1) (read-cycle-counter) 484 (let ((stop-gc-internal-run-time *gc-run-time*)) 485 (multiple-value-setq 486 (new-run-utime new-run-stime new-page-faults new-bytes-consed) 487 (time-get-sys-info)) 488 (setq new-real-time (- (get-internal-real-time) real-time-overhead)) 489 (let* ((gc-internal-run-time (max (- stop-gc-internal-run-time start-gc-internal-run-time) 0)) 490 (real-time (max (- new-real-time old-real-time) 0)) 491 (user-run-time (max (- new-run-utime old-run-utime) 0)) 492 (system-run-time (max (- new-run-stime old-run-stime) 0)) 493 (cycles (elapsed-cycles h0 l0 h1 l1)) 494 (page-faults (max (- new-page-faults old-page-faults) 0))) 495 (let (plist) 496 (flet ((note (name value &optional test) 497 (unless (and test (funcall test value)) 498 (setf plist (list* name value plist))))) 499 (note :aborted aborted #'not) 500 (note :bytes-consed (max (- new-bytes-consed old-bytes-consed) 0)) 501 (note :page-faults page-faults #'zerop) 502 ;; cycle counting isn't supported everywhere. 503 (when cycles 504 (note :processor-cycles cycles #'zerop) 505 (note :lambdas-converted sb!c::*lambda-conversions* #'zerop)) 506 (note :eval-calls *eval-calls* #'zerop) 507 (note :gc-run-time-ms gc-internal-run-time) 508 (note :system-run-time-us system-run-time) 509 (note :user-run-time-us user-run-time) 510 (note :real-time-ms real-time)) 511 (apply timer plist)))))))))) 512