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