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 (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
  21 time 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
  26 INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage.
  27 Includes both \"system\" and \"user\" time."
  28   (system-internal-run-time))
  29 \f
  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://heim.ifi.uio.no/~enag/lugm-time.html> for the choice of epoch
  50 ;;; here.  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 especially
  52 ;;; special, because it's disvisible by 400, hence the start of a 400 year
  53 ;;; 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
  97 format."
  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   "Returns number of complete years since March 1st 2000, and remainder in seconds"
 114   (let* ((days-in-year (* 86400 365))
 115          (days-in-4year (+ (* 4 days-in-year) 86400))
 116          (days-in-100year (- (* 25 days-in-4year) 86400))
 117          (days-in-400year (+ (* 4 days-in-100year) 86400))
 118          (offset (- utime +mar-1-2000+))
 119          (year 0))
 120     (labels ((whole-num (x y inc max)
 121                (let ((w (truncate x y)))
 122                  (when (and max (> w max)) (setf w max))
 123                  (incf year (* w inc))
 124                  (* w y))))
 125       (decf offset (whole-num offset days-in-400year 400 nil))
 126       (decf offset (whole-num offset days-in-100year 100 3))
 127       (decf offset (whole-num offset days-in-4year 4 25))
 128       (decf offset (whole-num offset days-in-year 1 3))
 129       (values year offset))))
 130
 131 (defun truncate-to-unix-range (utime)
 132   (let ((unix-time (- utime unix-to-universal-time)))
 133     (cond
 134       ((< unix-time (- (ash 1 31)))
 135        (multiple-value-bind (year offset) (years-since-mar-2000 utime)
 136          (declare (ignore year))
 137          (+  +mar-1-1903+  (- unix-to-universal-time)  offset)))
 138       ((>= unix-time (ash 1 31))
 139        (multiple-value-bind (year offset) (years-since-mar-2000 utime)
 140          (declare (ignore year))
 141          (+  +mar-1-2035+  (- unix-to-universal-time)  offset)))
 142       (t unix-time))))
 143
 144 (defun decode-universal-time (universal-time &optional time-zone)
 145   #!+sb-doc
 146   "Converts a universal-time to decoded time format returning the following
 147    nine values: second, minute, hour, date, month, year, day of week (0 =
 148    Monday), T (daylight savings time) or NIL (standard time), and timezone.
 149    Completely ignores daylight-savings-time when time-zone is supplied."
 150   (multiple-value-bind (daylight seconds-west)
 151       (if time-zone
 152           (values nil (* time-zone 60 60))
 153           (multiple-value-bind (ignore seconds-west daylight)
 154               (sb!unix::get-timezone (truncate-to-unix-range universal-time))
 155             (declare (ignore ignore))
 156             (declare (fixnum seconds-west))
 157             (values daylight seconds-west)))
 158     (declare (fixnum seconds-west))
 159     (multiple-value-bind (weeks secs)
 160         (truncate (+ (- universal-time seconds-west) seconds-offset)
 161                   seconds-in-week)
 162       (let ((weeks (+ weeks weeks-offset)))
 163         (multiple-value-bind (t1 second)
 164             (truncate secs 60)
 165           (let ((tday (truncate t1 minutes-per-day)))
 166             (multiple-value-bind (hour minute)
 167                 (truncate (- t1 (* tday minutes-per-day)) 60)
 168               (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
 169                      (tcent (truncate t2 quarter-days-per-century)))
 170                 (setq t2 (mod t2 quarter-days-per-century))
 171                 (setq t2 (+ (- t2 (mod t2 4)) 3))
 172                 (let* ((year (+ (* tcent 100)
 173                                 (truncate t2 quarter-days-per-year)))
 174                        (days-since-mar0
 175                         (1+ (truncate (mod t2 quarter-days-per-year) 4)))
 176                        (day (mod (+ tday weekday-november-17-1858) 7))
 177                        (t3 (+ (* days-since-mar0 5) 456)))
 178                   (cond ((>= t3 1989)
 179                          (setq t3 (- t3 1836))
 180                          (setq year (1+ year))))
 181                   (multiple-value-bind (month t3)
 182                       (truncate t3 153)
 183                     (let ((date (1+ (truncate t3 5))))
 184                       (values second minute hour date month year day
 185                               daylight
 186                               (if daylight
 187                                   (1+ (/ seconds-west 60 60))
 188                                   (/ seconds-west 60 60))))))))))))))
 189
 190 (defun pick-obvious-year (year)
 191   (declare (type (mod 100) year))
 192   (let* ((current-year (nth-value 5 (get-decoded-time)))
 193          (guess (+ year (* (truncate (- current-year 50) 100) 100))))
 194     (declare (type (integer 1900 9999) current-year guess))
 195     (if (> (- current-year guess) 50)
 196         (+ guess 100)
 197         guess)))
 198
 199 (defun leap-years-before (year)
 200   (let ((years (- year 1901)))
 201     (+ (- (truncate years 4)
 202           (truncate years 100))
 203        (truncate (+ years 300) 400))))
 204
 205 (defvar *days-before-month*
 206   #.(let ((reversed-result nil)
 207           (sum 0))
 208       (push nil reversed-result)
 209       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
 210         (push sum reversed-result)
 211         (incf sum days-in-month))
 212       (coerce (nreverse reversed-result) 'simple-vector)))
 213
 214
 215 (defun encode-universal-time (second minute hour date month year
 216                                      &optional time-zone)
 217   #!+sb-doc
 218   "The time values specified in decoded format are converted to
 219    universal time, which is returned."
 220   (declare (type (mod 60) second)
 221            (type (mod 60) minute)
 222            (type (mod 24) hour)
 223            (type (integer 1 31) date)
 224            (type (integer 1 12) month)
 225            (type (or (integer 0 99) (integer 1899)) year)
 226            ;; that type used to say (integer 1900), but that's
 227            ;; incorrect when a time-zone is specified: we should be
 228            ;; able to encode to produce 0 when a non-zero timezone is
 229            ;; specified - bem, 2005-08-09
 230            (type (or null rational) time-zone))
 231   (let* ((year (if (< year 100)
 232                    (pick-obvious-year year)
 233                    year))
 234          (days (+ (1- date)
 235                   (aref *days-before-month* month)
 236                   (if (> month 2)
 237                       (leap-years-before (1+ year))
 238                       (leap-years-before year))
 239                   (* (- year 1900) 365)))
 240          (hours (+ hour (* days 24)))
 241          (encoded-time 0))
 242     (if time-zone
 243         (setf encoded-time (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)))
 244         (let* ((secwest-guess
 245                 (sb!unix::unix-get-seconds-west
 246                  (truncate-to-unix-range (* hours 60 60))))
 247                (guess (+ second (* 60 (+ minute (* hours 60)))
 248                          secwest-guess))
 249                (secwest
 250                 (sb!unix::unix-get-seconds-west
 251                  (truncate-to-unix-range guess))))
 252           (setf encoded-time (+ guess (- secwest secwest-guess)))))
 253     (assert (typep encoded-time '(integer 0)))
 254     encoded-time))
 255 \f
 256 ;;;; TIME
 257
 258 (defvar *gc-run-time* 0
 259   #!+sb-doc
 260   "Total CPU time spent doing garbage collection (as reported by
 261 GET-INTERNAL-RUN-TIME.) Initialized to zero on startup. It is safe to bind
 262 this to zero in order to measure GC time inside a certain section of code, but
 263 doing so may interfere with results reported by eg. TIME.")
 264 (declaim (type index *gc-run-time*))
 265
 266 (defun print-time (&key real-time-ms user-run-time-us system-run-time-us
 267                    gc-run-time-ms processor-cycles eval-calls
 268                    lambdas-converted page-faults bytes-consed
 269                    aborted)
 270   (let ((total-run-time-us (+ user-run-time-us system-run-time-us)))
 271     (format *trace-output*
 272             "~&Evaluation took:~%~
 273                          ~@<  ~@;~/sb-impl::format-milliseconds/ of real time~%~
 274                                  ~/sb-impl::format-microseconds/ of total run time ~
 275                                   (~@/sb-impl::format-microseconds/ user, ~@/sb-impl::format-microseconds/ system)~%~
 276                                  ~[[ Run times consist of ~/sb-impl::format-milliseconds/ GC time, ~
 277                                                       and ~/sb-impl::format-milliseconds/ non-GC time. ]~%~;~2*~]~
 278                                  ~,2F% CPU~%~
 279                                  ~@[~:D form~:P interpreted~%~]~
 280                                  ~@[~:D lambda~:P converted~%~]~
 281                                  ~@[~:D processor cycles~%~]~
 282                                  ~@[~:D page fault~:P~%~]~
 283                                  ~:D bytes consed~%~
 284                                  ~@[~%before it was aborted by a non-local transfer of control.~%~]~:>~%"
 285             real-time-ms
 286             total-run-time-us
 287             user-run-time-us
 288             system-run-time-us
 289             (if (zerop gc-run-time-ms) 1 0)
 290             gc-run-time-ms
 291             ;; Round up so we don't mislead by saying 0.0 seconds of non-GC time...
 292             (- (ceiling total-run-time-us 1000) gc-run-time-ms)
 293             (if (zerop real-time-ms)
 294                 100.0
 295                 (float (* 100 (/ (round total-run-time-us 1000) real-time-ms))))
 296             eval-calls
 297             lambdas-converted
 298             processor-cycles
 299             page-faults
 300             bytes-consed
 301             aborted)))
 302
 303 (defmacro time (form)
 304   #!+sb-doc
 305   "Execute FORM and print timing information on *TRACE-OUTPUT*.
 306
 307 On some hardware platforms estimated processor cycle counts are
 308 included in this output; this number is slightly inflated, since it
 309 includes the pipeline involved in reading the cycle counter --
 310 executing \(TIME NIL) a few times will give you an idea of the
 311 overhead, and its variance. The cycle counters are also per processor,
 312 not per thread: if multiple threads are running on the same processor,
 313 the reported counts will include cycles taken up by all threads
 314 running on the processor where TIME was executed. Furthermore, if the
 315 operating system migrates the thread to another processor between
 316 reads of the cycle counter, the results will be completely bogus.
 317 Finally, the counter is cycle counter, incremented by the hardware
 318 even when the process is halted -- which is to say that cycles pass
 319 normally during operations like SLEEP."
 320   `(call-with-timing #'print-time (lambda () ,form)))
 321
 322 ;;; Return all the data that we want TIME to report.
 323 (defun time-get-sys-info ()
 324   (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
 325     (values user sys faults (get-bytes-consed))))
 326
 327 (defun elapsed-cycles (h0 l0 h1 l1)
 328   (declare (ignorable h0 l0 h1 l1))
 329   #!+cycle-counter
 330   (+ (ash (- h1 h0) 32)
 331      (- l1 l0))
 332   #!-cycle-counter
 333   nil)
 334 (declaim (inline read-cycle-counter))
 335 (defun read-cycle-counter ()
 336   #!+cycle-counter
 337   (sb!vm::%read-cycle-counter)
 338   #!-cycle-counter
 339   (values 0 0))
 340
 341 ;;; This is so that we don't have to worry about the vagaries of
 342 ;;; floating point printing, or about conversions to floats dropping
 343 ;;; or introducing decimals, which are liable to imply wrong precision.
 344 (defun format-microseconds (stream usec &optional colonp atp)
 345   (declare (ignore colonp))
 346   (%format-decimal stream usec 6)
 347   (unless atp
 348     (write-string " seconds" stream)))
 349
 350 (defun format-milliseconds (stream usec &optional colonp atp)
 351   (declare (ignore colonp))
 352   (%format-decimal stream usec 3)
 353   (unless atp
 354     (write-string " seconds" stream)))
 355
 356 (defun %format-decimal (stream number power)
 357   (declare (stream stream)
 358            (integer number power))
 359   (when (minusp number)
 360     (write-char #\- stream)
 361     (setf number (- number)))
 362   (let ((scale (expt 10 power)))
 363     (labels ((%fraction (fraction)
 364                (if (zerop fraction)
 365                    (%zeroes)
 366                    (let ((scaled (* 10 fraction)))
 367                      (loop while (< scaled scale)
 368                            do (write-char #\0 stream)
 369                               (setf scaled (* scaled 10)))))
 370                (format stream "~D" fraction))
 371              (%zeroes ()
 372                (let ((scaled (/ scale 10)))
 373                  (write-char #\0 stream)
 374                  (loop while (> scaled 1)
 375                        do (write-char #\0 stream)
 376                           (setf scaled (/ scaled 10))))))
 377       (cond ((zerop number)
 378              (write-string "0." stream)
 379              (%zeroes))
 380             ((< number scale)
 381              (write-string "0." stream)
 382              (%fraction number))
 383             ((= number scale)
 384              (write-string "1." stream)
 385              (%zeroes))
 386             ((> number scale)
 387              (multiple-value-bind (whole fraction) (floor number scale)
 388                (format stream "~D." whole)
 389                (%fraction fraction))))))
 390   nil)
 391
 392 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
 393 ;;; function, report the times.
 394 (defun call-with-timing (timer function &rest arguments)
 395   #!+sb-doc
 396   "Calls FUNCTION with ARGUMENTS, and gathers timing infomation about it.
 397 Then calls TIMER with keyword arguments describing the information collected.
 398 Calls TIMER even if FUNCTION performs a non-local transfer of control. Finally
 399 returns values returned by FUNCTION.
 400
 401   :USER-RUN-TIME-US
 402       User run time in microseconds.
 403
 404   :SYSTEM-RUN-TIME-US
 405       System run time in microseconds.
 406
 407   :REAL-TIME-MS
 408       Real time in milliseconds.
 409
 410   :GC-RUN-TIME-MS
 411       GC run time in milliseconds (included in user and system run time.)
 412
 413   :PROCESSOR-CYCLES
 414       Approximate number of processor cycles used. (Omitted  if not supported on
 415       the platform -- currently available on x86 and x86-64 only.)
 416
 417   :EVAL-CALLS
 418       Number of calls to EVAL. (Omitted if zero.)
 419
 420   :LAMBDAS-CONVERTED
 421       Number of lambdas converted. (Omitted if zero.)
 422
 423   :PAGE-FAULTS
 424       Number of page faults. (Omitted if zero.)
 425
 426   :BYTES-CONSED
 427       Approximate number of bytes consed.
 428
 429   :ABORTED
 430       True if FUNCTION caused a non-local transfer of control. (Omitted if
 431       NIL.)
 432
 433 EXPERIMENTAL: Interface subject to change."
 434   (let (old-run-utime
 435         new-run-utime
 436         old-run-stime
 437         new-run-stime
 438         old-real-time
 439         new-real-time
 440         old-page-faults
 441         new-page-faults
 442         real-time-overhead
 443         run-utime-overhead
 444         run-stime-overhead
 445         page-faults-overhead
 446         old-bytes-consed
 447         new-bytes-consed
 448         cons-overhead
 449         (fun (if (functionp function) function (fdefinition function))))
 450     (declare (function fun))
 451     ;; Calculate the overhead...
 452     (multiple-value-setq
 453         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 454       (time-get-sys-info))
 455     ;; Do it a second time to make sure everything is faulted in.
 456     (multiple-value-setq
 457         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 458       (time-get-sys-info))
 459     (multiple-value-setq
 460         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 461       (time-get-sys-info))
 462     (setq run-utime-overhead (- new-run-utime old-run-utime))
 463     (setq run-stime-overhead (- new-run-stime old-run-stime))
 464     (setq page-faults-overhead (- new-page-faults old-page-faults))
 465     (setq old-real-time (get-internal-real-time))
 466     (setq old-real-time (get-internal-real-time))
 467     (setq new-real-time (get-internal-real-time))
 468     (setq real-time-overhead (- new-real-time old-real-time))
 469     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
 470     ;; Now get the initial times.
 471     (multiple-value-setq
 472         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 473       (time-get-sys-info))
 474     (setq old-real-time (get-internal-real-time))
 475     (let ((start-gc-internal-run-time *gc-run-time*)
 476           (*eval-calls* 0)
 477           (sb!c::*lambda-conversions* 0)
 478           (aborted t))
 479       (declare (special *eval-calls* sb!c::*lambda-conversions*))
 480       (multiple-value-bind (h0 l0) (read-cycle-counter)
 481         (unwind-protect
 482              (multiple-value-prog1 (apply fun arguments)
 483                (setf aborted nil))
 484           (multiple-value-bind (h1 l1) (read-cycle-counter)
 485             (let ((stop-gc-internal-run-time *gc-run-time*))
 486               (multiple-value-setq
 487                   (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 488                 (time-get-sys-info))
 489               (setq new-real-time (- (get-internal-real-time) real-time-overhead))
 490               (let* ((gc-internal-run-time (max (- stop-gc-internal-run-time start-gc-internal-run-time) 0))
 491                      (real-time (max (- new-real-time old-real-time) 0))
 492                      (user-run-time (max (- new-run-utime old-run-utime) 0))
 493                      (system-run-time (max (- new-run-stime old-run-stime) 0))
 494                      (cycles (elapsed-cycles h0 l0 h1 l1))
 495                      (page-faults (max (- new-page-faults old-page-faults) 0)))
 496                 (let (plist)
 497                   (flet ((note (name value &optional test)
 498                            (unless (and test (funcall test value))
 499                              (setf plist (list* name value plist)))))
 500                     (note :aborted aborted #'not)
 501                     (note :bytes-consed (max (- new-bytes-consed old-bytes-consed) 0))
 502                     (note :page-faults page-faults #'zerop)
 503                     ;; cycle counting isn't supported everywhere.
 504                     (when cycles
 505                       (note :processor-cycles cycles #'zerop)
 506                     (note :lambdas-converted sb!c::*lambda-conversions* #'zerop))
 507                     (note :eval-calls *eval-calls* #'zerop)
 508                     (note :gc-run-time-ms gc-internal-run-time)
 509                     (note :system-run-time-us system-run-time)
 510                     (note :user-run-time-us user-run-time)
 511                     (note :real-time-ms real-time))
 512                   (apply timer plist))))))))))