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