0.pre8.4
[sbcl.git] / src / code / time.lisp
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 (defconstant sb!xc:internal-time-units-per-second 1000
15   #!+sb-doc
16   "The number of internal time units that fit into a second. See
17   GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.")
18
19 (defconstant micro-seconds-per-internal-time-unit
20   (/ 1000000 sb!xc:internal-time-units-per-second))
21 \f
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*))
27
28 (defun get-internal-real-time ()
29   #!+sb-doc
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   (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
33     (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
34     (let ((base *internal-real-time-base-seconds*)
35           (uint (truncate useconds
36                           micro-seconds-per-internal-time-unit)))
37       (declare (type (unsigned-byte 32) uint))
38       (cond (base
39              (truly-the (unsigned-byte 32)
40                         (+ (the (unsigned-byte 32)
41                                 (* (the (unsigned-byte 32) (- seconds base))
42                                    sb!xc:internal-time-units-per-second))
43                            uint)))
44             (t
45              (setq *internal-real-time-base-seconds* seconds)
46              uint)))))
47
48 (defun get-internal-run-time ()
49   #!+sb-doc
50   "Return the run time in the internal time format. This is useful for
51   finding CPU usage."
52   (declare (values (unsigned-byte 32)))
53   (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
54       (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
55     (declare (ignore ignore)
56              (type (unsigned-byte 31) utime-sec stime-sec)
57              ;; (Classic CMU CL had these (MOD 1000000) instead, but
58              ;; at least in Linux 2.2.12, the type doesn't seem to be
59              ;; documented anywhere and the observed behavior is to
60              ;; sometimes return 1000000 exactly.)
61              (type (integer 0 1000000) utime-usec stime-usec))
62     (let ((result (+ (the (unsigned-byte 32)
63                           (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
64                              sb!xc:internal-time-units-per-second))
65                      (floor (+ utime-usec
66                                stime-usec
67                                (floor micro-seconds-per-internal-time-unit 2))
68                             micro-seconds-per-internal-time-unit))))
69       result)))
70 \f
71 ;;;; Encode and decode universal times.
72
73 ;;; Subtract from the returned Internal-Time to get the universal
74 ;;; time. The offset between our time base and the Perq one is 2145
75 ;;; weeks and five days.
76 (defconstant seconds-in-week (* 60 60 24 7))
77 (defconstant weeks-offset 2145)
78 (defconstant seconds-offset 432000)
79 (defconstant minutes-per-day (* 24 60))
80 (defconstant quarter-days-per-year (1+ (* 365 4)))
81 (defconstant quarter-days-per-century 146097)
82 (defconstant november-17-1858 678882)
83 (defconstant weekday-november-17-1858 2)
84 (defconstant unix-to-universal-time 2208988800)
85
86 (defun get-universal-time ()
87   #!+sb-doc
88   "Return a single integer for the current time of
89    day in universal time format."
90   (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
91     (declare (ignore res))
92     (+ secs unix-to-universal-time)))
93
94 (defun get-decoded-time ()
95   #!+sb-doc
96   "Return nine values specifying the current time as follows:
97    second, minute, hour, date, month, year, day of week (0 = Monday), T
98    (daylight savings times) or NIL (standard time), and timezone."
99   (decode-universal-time (get-universal-time)))
100
101 (defun decode-universal-time (universal-time &optional time-zone)
102   #!+sb-doc
103   "Converts a universal-time to decoded time format returning the following
104    nine values: second, minute, hour, date, month, year, day of week (0 =
105    Monday), T (daylight savings time) or NIL (standard time), and timezone.
106    Completely ignores daylight-savings-time when time-zone is supplied."
107   (multiple-value-bind (weeks secs)
108       (truncate (+ universal-time seconds-offset)
109                 seconds-in-week)
110     (let* ((weeks (+ weeks weeks-offset))
111            (second NIL)
112            (minute NIL)
113            (hour NIL)
114            (date NIL)
115            (month NIL)
116            (year NIL)
117            (day NIL)
118            (daylight NIL)
119            (timezone (cond
120                        ((null time-zone)
121                         (multiple-value-bind
122                               (ignore minwest dst)
123                             (sb!unix::get-timezone (- universal-time
124                                                       unix-to-universal-time))
125                           (declare (ignore ignore))
126                           (declare (fixnum minwest))
127                           (setf daylight dst)
128                           minwest))
129                        (t (* time-zone 60)))))
130       (declare (fixnum timezone))
131       (multiple-value-bind (t1 seconds) (truncate secs 60)
132         (setq second seconds)
133         (setq t1 (- t1 timezone))
134         (let* ((tday (if (< t1 0)
135                          (1- (truncate (1+ t1) minutes-per-day))
136                          (truncate t1 minutes-per-day))))
137           (multiple-value-setq (hour minute)
138             (truncate (- t1 (* tday minutes-per-day)) 60))
139           (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
140                  (tcent (truncate t2 quarter-days-per-century)))
141             (setq t2 (mod t2 quarter-days-per-century))
142             (setq t2 (+ (- t2 (mod t2 4)) 3))
143             (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
144             (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
145                                                  4))))
146               (setq day (mod (+ tday weekday-november-17-1858) 7))
147               (let ((t3 (+ (* days-since-mar0 5) 456)))
148                 (cond ((>= t3 1989)
149                        (setq t3 (- t3 1836))
150                        (setq year (1+ year))))
151                 (multiple-value-setq (month t3) (truncate t3 153))
152                 (setq date (1+ (truncate t3 5))))))))
153       (values second minute hour date month year day
154               daylight
155               (if daylight
156                   (1+ (/ timezone 60))
157                   (/ timezone 60))))))
158
159 (defun pick-obvious-year (year)
160   (declare (type (mod 100) year))
161   (let* ((current-year (nth-value 5 (get-decoded-time)))
162          (guess (+ year (* (truncate (- current-year 50) 100) 100))))
163     (declare (type (integer 1900 9999) current-year guess))
164     (if (> (- current-year guess) 50)
165         (+ guess 100)
166         guess)))
167
168 (defun leap-years-before (year)
169   (let ((years (- year 1901)))
170     (+ (- (truncate years 4)
171           (truncate years 100))
172        (truncate (+ years 300) 400))))
173
174 (defvar *days-before-month*
175   #.(let ((reversed-result nil)
176           (sum 0))
177       (push nil reversed-result)
178       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
179         (push sum reversed-result)
180         (incf sum days-in-month))
181       (coerce (nreverse reversed-result) 'simple-vector)))
182
183 (defun encode-universal-time (second minute hour date month year
184                                      &optional time-zone)
185   #!+sb-doc
186   "The time values specified in decoded format are converted to
187    universal time, which is returned."
188   (declare (type (mod 60) second)
189            (type (mod 60) minute)
190            (type (mod 24) hour)
191            (type (integer 1 31) date)
192            (type (integer 1 12) month)
193            (type (or (integer 0 99) (integer 1900)) year)
194            (type (or null rational) time-zone))
195   (let* ((year (if (< year 100)
196                    (pick-obvious-year year)
197                    year))
198          (days (+ (1- date)
199                   (aref *days-before-month* month)
200                   (if (> month 2)
201                       (leap-years-before (1+ year))
202                       (leap-years-before year))
203                   (* (- year 1900) 365)))
204          (hours (+ hour (* days 24))))
205     (if time-zone
206         (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
207         (let* ((minwest-guess
208                 (sb!unix::unix-get-minutes-west (- (* hours 60 60)
209                                                   unix-to-universal-time)))
210                (guess (+ minute (* hours 60) minwest-guess))
211                (minwest
212                 (sb!unix::unix-get-minutes-west (- (* guess 60)
213                                                   unix-to-universal-time))))
214           (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
215 \f
216 ;;;; TIME
217
218 (defmacro time (form)
219   #!+sb-doc
220   "Execute FORM and print timing information on *TRACE-OUTPUT*."
221   `(%time (lambda () ,form)))
222
223 ;;; Return all the data that we want TIME to report.
224 (defun time-get-sys-info ()
225   (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
226     (values user sys faults (get-bytes-consed))))
227
228 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
229 ;;; function, report the times.
230 (defun %time (fun)
231   (declare (type function fun))
232   (let (old-run-utime
233         new-run-utime
234         old-run-stime
235         new-run-stime
236         old-real-time
237         new-real-time
238         old-page-faults
239         new-page-faults
240         real-time-overhead
241         run-utime-overhead
242         run-stime-overhead
243         page-faults-overhead
244         old-bytes-consed
245         new-bytes-consed
246         cons-overhead)
247     ;; Calculate the overhead...
248     (multiple-value-setq
249         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
250       (time-get-sys-info))
251     ;; Do it a second time to make sure everything is faulted in.
252     (multiple-value-setq
253         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
254       (time-get-sys-info))
255     (multiple-value-setq
256         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
257       (time-get-sys-info))
258     (setq run-utime-overhead (- new-run-utime old-run-utime))
259     (setq run-stime-overhead (- new-run-stime old-run-stime))
260     (setq page-faults-overhead (- new-page-faults old-page-faults))
261     (setq old-real-time (get-internal-real-time))
262     (setq old-real-time (get-internal-real-time))
263     (setq new-real-time (get-internal-real-time))
264     (setq real-time-overhead (- new-real-time old-real-time))
265     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
266     ;; Now get the initial times.
267     (multiple-value-setq
268         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
269       (time-get-sys-info))
270     (setq old-real-time (get-internal-real-time))
271     (let ((start-gc-run-time *gc-run-time*))
272     (multiple-value-prog1
273         ;; Execute the form and return its values.
274         (funcall fun)
275       (multiple-value-setq
276           (new-run-utime new-run-stime new-page-faults new-bytes-consed)
277         (time-get-sys-info))
278       (setq new-real-time (- (get-internal-real-time) real-time-overhead))
279       (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
280         (format *trace-output*
281                 "~&Evaluation took:~%  ~
282                  ~S second~:P of real time~%  ~
283                  ~S second~:P of user run time~%  ~
284                  ~S second~:P of system run time~%  ~
285 ~@[                 [Run times include ~S second~:P GC run time.]~%  ~]~
286                  ~S page fault~:P and~%  ~
287                  ~S bytes consed.~%"
288                 (max (/ (- new-real-time old-real-time)
289                         (float sb!xc:internal-time-units-per-second))
290                      0.0)
291                 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
292                 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
293                 (unless (zerop gc-run-time)
294                   (/ (float gc-run-time)
295                      (float sb!xc:internal-time-units-per-second)))
296                 (max (- new-page-faults old-page-faults) 0)
297                 (max (- new-bytes-consed old-bytes-consed) 0)))))))