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 (defconstant internal-time-units-per-second 100
16 "The number of internal time units that fit into a second. See
17 GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.")
19 (defconstant micro-seconds-per-internal-time-unit
20 (/ 1000000 internal-time-units-per-second))
22 ;;; The base number of seconds for our internal "epoch". We initialize
23 ;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and
24 ;;; then subtract this out of the result.
25 (defvar *internal-real-time-base-seconds* nil)
26 (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
28 (defun get-internal-real-time ()
30 "Return the real time in the internal time format. This is useful for
31 finding elapsed time. See INTERNAL-TIME-UNITS-PER-SECOND."
32 ;; FIXME: See comment on OPTIMIZE declaration in GET-INTERNAL-RUN-TIME.
33 (declare (optimize (speed 3) (safety 3)))
34 (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
35 (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
36 (let ((base *internal-real-time-base-seconds*)
37 (uint (truncate useconds
38 micro-seconds-per-internal-time-unit)))
39 (declare (type (unsigned-byte 32) uint))
41 (truly-the (unsigned-byte 32)
42 (+ (the (unsigned-byte 32)
43 (* (the (unsigned-byte 32) (- seconds base))
44 internal-time-units-per-second))
47 (setq *internal-real-time-base-seconds* seconds)
50 ;;; REMOVEME once runtime nonmonotonicity problem is debugged
51 (defvar *last-utime-sec*)
52 (defvar *last-utime-usec*)
53 (defvar *last-stime-sec*)
54 (defvar *last-stime-usec*)
55 (defvar *last-internal-run-time*)
57 (makunbound '*last-internal-run-time*))
58 *before-save-initializations*)
60 (defun get-internal-run-time ()
62 "Return the run time in the internal time format. This is useful for
64 (declare (values (unsigned-byte 32)))
65 ;; FIXME: In CMU CL this was (SPEED 3) (SAFETY 0), and perhaps
66 ;; someday it should be again, since overhead here is annoying. But
67 ;; it's even more annoying to worry about this function returning
68 ;; out-of-range values, so while debugging the profiling code,
69 ;; I set it to (SAFETY 3) for now.
70 (declare (optimize (speed 3) (safety 3)))
71 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
72 (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
73 (declare (ignore ignore)
74 (type (unsigned-byte 31) utime-sec stime-sec)
75 ;; (Classic CMU CL had these (MOD 1000000) instead, but
76 ;; at least in Linux 2.2.12, the type doesn't seem to be
77 ;; documented anywhere and the observed behavior is to
78 ;; sometimes return 1000000 exactly.)
79 (type (integer 0 1000000) utime-usec stime-usec))
81 (let ((result (+ (the (unsigned-byte 32)
82 (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
83 internal-time-units-per-second))
86 (floor micro-seconds-per-internal-time-unit 2))
87 micro-seconds-per-internal-time-unit))))
89 ;; REMOVEME once runtime nonmonotonicity problem is debugged
90 (when (boundp '*last-internal-run-time*)
91 (unless (>= result *last-internal-run-time*)
92 (error "non-monotonic:~@
98 *last-utime-sec* utime-sec
99 *last-utime-usec* utime-usec
100 *last-stime-sec* stime-sec
101 *last-stime-usec* stime-usec
102 *last-internal-run-time* result)))
103 (setf *last-utime-sec* utime-sec
104 *last-utime-usec* utime-usec
105 *last-stime-sec* stime-sec
106 *last-stime-usec* stime-usec
107 *last-internal-run-time* result)
111 ;;;; Encode and decode universal times.
113 ;;; Returns two values:
114 ;;; - the minutes west of GMT.
115 ;;; - T if daylight savings is in effect, NIL if not.
116 (sb!alien:def-alien-routine get-timezone sb!c-call:void
117 (when sb!c-call:long :in)
118 (minutes-west sb!c-call:int :out)
119 (daylight-savings-p sb!alien:boolean :out))
121 ;;; Subtract from the returned Internal-Time to get the universal
122 ;;; time. The offset between our time base and the Perq one is 2145
123 ;;; weeks and five days.
124 (defconstant seconds-in-week (* 60 60 24 7))
125 (defconstant weeks-offset 2145)
126 (defconstant seconds-offset 432000)
127 (defconstant minutes-per-day (* 24 60))
128 (defconstant quarter-days-per-year (1+ (* 365 4)))
129 (defconstant quarter-days-per-century 146097)
130 (defconstant november-17-1858 678882)
131 (defconstant weekday-november-17-1858 2)
132 (defconstant unix-to-universal-time 2208988800)
134 (defun get-universal-time ()
136 "Returns a single integer for the current time of
137 day in universal time format."
138 (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
139 (declare (ignore res))
140 (+ secs unix-to-universal-time)))
142 (defun get-decoded-time ()
144 "Returns nine values specifying the current time as follows:
145 second, minute, hour, date, month, year, day of week (0 = Monday), T
146 (daylight savings times) or NIL (standard time), and timezone."
147 (decode-universal-time (get-universal-time)))
149 (defun decode-universal-time (universal-time &optional time-zone)
151 "Converts a universal-time to decoded time format returning the following
152 nine values: second, minute, hour, date, month, year, day of week (0 =
153 Monday), T (daylight savings time) or NIL (standard time), and timezone.
154 Completely ignores daylight-savings-time when time-zone is supplied."
155 (multiple-value-bind (weeks secs)
156 (truncate (+ universal-time seconds-offset)
158 (let* ((weeks (+ weeks weeks-offset))
167 (timezone (if (null time-zone)
170 (get-timezone (- universal-time
171 unix-to-universal-time))
172 (declare (ignore ignore))
176 (declare (fixnum timezone))
177 (multiple-value-bind (t1 seconds) (truncate secs 60)
178 (setq second seconds)
179 (setq t1 (- t1 timezone))
180 (let* ((tday (if (< t1 0)
181 (1- (truncate (1+ t1) minutes-per-day))
182 (truncate t1 minutes-per-day))))
183 (multiple-value-setq (hour minute)
184 (truncate (- t1 (* tday minutes-per-day)) 60))
185 (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
186 (tcent (truncate t2 quarter-days-per-century)))
187 (setq t2 (mod t2 quarter-days-per-century))
188 (setq t2 (+ (- t2 (mod t2 4)) 3))
189 (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
190 (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
192 (setq day (mod (+ tday weekday-november-17-1858) 7))
193 (let ((t3 (+ (* days-since-mar0 5) 456)))
195 (setq t3 (- t3 1836))
196 (setq year (1+ year))))
197 (multiple-value-setq (month t3) (truncate t3 153))
198 (setq date (1+ (truncate t3 5))))))))
199 (values second minute hour date month year day
205 (defun pick-obvious-year (year)
206 (declare (type (mod 100) year))
207 (let* ((current-year (nth-value 5 (get-decoded-time)))
208 (guess (+ year (* (truncate (- current-year 50) 100) 100))))
209 (declare (type (integer 1900 9999) current-year guess))
210 (if (> (- current-year guess) 50)
214 (defun leap-years-before (year)
215 (let ((years (- year 1901)))
216 (+ (- (truncate years 4)
217 (truncate years 100))
218 (truncate (+ years 300) 400))))
220 (defvar *days-before-month*
221 #.(let ((reversed-result nil)
223 (push nil reversed-result)
224 (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
225 (push sum reversed-result)
226 (incf sum days-in-month))
227 (coerce (nreverse reversed-result) 'simple-vector)))
229 (defun encode-universal-time (second minute hour date month year
232 "The time values specified in decoded format are converted to
233 universal time, which is returned."
234 (declare (type (mod 60) second)
235 (type (mod 60) minute)
237 (type (integer 1 31) date)
238 (type (integer 1 12) month)
239 (type (or (integer 0 99) (integer 1900)) year)
240 (type (or null rational) time-zone))
241 (let* ((year (if (< year 100)
242 (pick-obvious-year year)
245 (aref *days-before-month* month)
247 (leap-years-before (1+ year))
248 (leap-years-before year))
249 (* (- year 1900) 365)))
250 (hours (+ hour (* days 24))))
252 (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
253 (let* ((minwest-guess
255 (get-timezone (- (* hours 60 60)
256 unix-to-universal-time))))
257 (guess (+ minute (* hours 60) minwest-guess))
260 (get-timezone (- (* guess 60)
261 unix-to-universal-time)))))
262 (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
266 (defmacro time (form)
268 "Evaluates the Form and prints timing information on *Trace-Output*."
269 `(%time #'(lambda () ,form)))
271 ;;; Try to compile the closure arg to %TIME if it is interpreted.
272 (defun massage-time-function (fun)
274 ((sb!eval:interpreted-function-p fun)
275 (multiple-value-bind (def env-p) (function-lambda-expression fun)
276 (declare (ignore def))
279 (warn "non-null environment for TIME form, forced to interpret.~@
280 Compiling the entire form will produce more accurate times.")
283 (compile nil fun)))))
286 ;;; Return all the data that we want TIME to report.
287 (defun time-get-sys-info ()
288 (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
289 (values user sys faults (get-bytes-consed))))
291 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
292 ;;; function, report the times.
294 (let ((fun (massage-time-function fun))
310 ;; Calculate the overhead...
312 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
314 ;; Do it a second time to make sure everything is faulted in.
316 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
319 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
321 (setq run-utime-overhead (- new-run-utime old-run-utime))
322 (setq run-stime-overhead (- new-run-stime old-run-stime))
323 (setq page-faults-overhead (- new-page-faults old-page-faults))
324 (setq old-real-time (get-internal-real-time))
325 (setq old-real-time (get-internal-real-time))
326 (setq new-real-time (get-internal-real-time))
327 (setq real-time-overhead (- new-real-time old-real-time))
328 (setq cons-overhead (- new-bytes-consed old-bytes-consed))
329 ;; Now get the initial times.
331 (old-run-utime old-run-stime old-page-faults old-bytes-consed)
333 (setq old-real-time (get-internal-real-time))
334 (let ((start-gc-run-time *gc-run-time*))
335 (multiple-value-prog1
336 ;; Execute the form and return its values.
339 (new-run-utime new-run-stime new-page-faults new-bytes-consed)
341 (setq new-real-time (- (get-internal-real-time) real-time-overhead))
342 (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
343 (format *trace-output*
344 "~&Evaluation took:~% ~
345 ~S second~:P of real time~% ~
346 ~S second~:P of user run time~% ~
347 ~S second~:P of system run time~% ~
348 ~@[ [Run times include ~S second~:P GC run time.]~% ~]~
349 ~S page fault~:P and~% ~
351 (max (/ (- new-real-time old-real-time)
352 (float internal-time-units-per-second))
354 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
355 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
356 (unless (zerop gc-run-time)
357 (/ (float gc-run-time)
358 (float internal-time-units-per-second)))
359 (max (- new-page-faults old-page-faults) 0)
360 (max (- new-bytes-consed old-bytes-consed) 0)))))))