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
  22 (defconstant 100ns-per-internal-time-unit
  23   (/ 10000000 internal-time-units-per-second))
  24 \f
  25 ;;; The base number of seconds for our internal "epoch". We initialize
  26 ;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and
  27 ;;; then subtract this out of the result.
  28 (defvar *internal-real-time-base-seconds* nil)
  29 (declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
  30
  31 (defun get-internal-real-time ()
  32   #!+sb-doc
  33   "Return the real time in the internal time format. (See
  34   INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time."
  35   (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
  36     (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
  37     (let ((base *internal-real-time-base-seconds*)
  38           (uint (truncate useconds
  39                           micro-seconds-per-internal-time-unit)))
  40       (declare (type (unsigned-byte 32) uint))
  41       (cond (base
  42              (+ (* (- seconds base)
  43                    sb!xc:internal-time-units-per-second)
  44                 uint))
  45             (t
  46              (setq *internal-real-time-base-seconds* seconds)
  47              uint)))))
  48
  49 (defun get-internal-run-time ()
  50   #!+sb-doc
  51   "Return the run time in the internal time format. (See
  52   INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage."
  53   ;; FIXME: This is yet another creeping malaise: instead of #+/-win32
  54   ;; conditionals things like these need to be split into wholly separate
  55   ;; implementations of get-internal-run-time, probably one in
  56   ;; unix.lisp and one in win32.lisp -- that however requires also
  57   ;; cleaning up unix.lisp sufficiently to remove it from the Windows build.
  58   #-win32
  59   (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
  60       (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
  61     (declare (ignore ignore)
  62              (type (unsigned-byte 31) utime-sec stime-sec)
  63              ;; (Classic CMU CL had these (MOD 1000000) instead, but
  64              ;; at least in Linux 2.2.12, the type doesn't seem to be
  65              ;; documented anywhere and the observed behavior is to
  66              ;; sometimes return 1000000 exactly.)
  67              (type (integer 0 1000000) utime-usec stime-usec))
  68     (let ((result (+ (* (+ utime-sec stime-sec)
  69                         sb!xc:internal-time-units-per-second)
  70                      (floor (+ utime-usec
  71                                stime-usec
  72                                (floor micro-seconds-per-internal-time-unit 2))
  73                             micro-seconds-per-internal-time-unit))))
  74       result))
  75   #!+win32
  76   (multiple-value-bind
  77         (creation-time exit-time kernel-time user-time)
  78       (sb!win32:get-process-times)
  79     (declare (ignore creation-time exit-time))
  80     (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
  81 \f
  82 ;;;; Encode and decode universal times.
  83
  84 ;;; In August 2003, work was done in this file for more plausible
  85 ;;; timezone handling after the unix timezone database runs out in
  86 ;;; 2038.  We assume that timezone rules are trending sane rather than
  87 ;;; insane, so for all years after the end of time_t we apply the
  88 ;;; rules for 2035/2036 instead of the actual date asked for.  Making
  89 ;;; the same assumption about the early 1900s would be less
  90 ;;; reasonable, however, so please note that we're still broken for
  91 ;;; local time between 1900-1-1 and 1901-12-13
  92
  93 ;;; It should be noted that 64 bit machines don't actually fix this
  94 ;;; problem, at least as of 2003, because the Unix zonefiles are
  95 ;;; specified in terms of 32 bit fields even on, say, the Alpha.  So,
  96 ;;; references to the range of time_t elsewhere in this file should
  97 ;;; rightly be read as shorthand for the range of an signed 32 bit
  98 ;;; number of seconds since 1970-01-01
  99
 100 ;;; I'm obliged to Erik Naggum's "Long, Painful History of Time" paper
 101 ;;; <http://heim.ifi.uio.no/~enag/lugm-time.html> for the choice of epoch
 102 ;;; here.  By starting the year in March, we avoid having to test the month
 103 ;;; whenever deciding whether to account for a leap day.  2000 is especially
 104 ;;; special, because it's disvisible by 400, hence the start of a 400 year
 105 ;;; leap year cycle
 106
 107 ;;; If a universal-time is after time_t runs out, we find its offset
 108 ;;; from 1st March of whichever year it falls in, then add that to
 109 ;;; 2035-3-1.  This date has two relevant properties: (1) somewhere
 110 ;;; near the end of time_t, and (2) preceding a leap year.  Thus a
 111 ;;; date which is e.g. 365.5 days from March 1st in its year will be
 112 ;;; treated for timezone lookup as if it were Feb 29th 2036
 113
 114 ;;; This epoch is used only for fixing the timezones-outside-time_t
 115 ;;; problem.  Someday it would be nice to come back to this code and
 116 ;;; see if the rest of the file and its references to Spice Lisp
 117 ;;; history (Perq time base?) could be cleaned up any on this basis.
 118 ;;; -- dan, 2003-08-08
 119
 120 ;;; In order to accomodate universal times between January 1st 1900
 121 ;;; and sometime on December 13th 1901, I'm doing the same calculation
 122 ;;; as described above in order to handle dates in that interval, by
 123 ;;; normalizing them to March 1st 1903, which shares the same special
 124 ;;; properties described above (except for the 400-year property, but
 125 ;;; this isn't an issue for the limited range we need to handle).
 126
 127 ;;; One open issue is whether to pass UNIX a 64-bit time_t value on
 128 ;;; 64-bit platforms. I don't know if time_t is always 64-bit on those
 129 ;;; platforms, and looking at this file reveals a scary amount of
 130 ;;; literal 31 and 32s.
 131 ;;; -- bem, 2005-08-09
 132
 133 ;;; Subtract from the returned Internal-Time to get the universal
 134 ;;; time. The offset between our time base and the Perq one is 2145
 135 ;;; weeks and five days.
 136 (defconstant seconds-in-week (* 60 60 24 7))
 137 (defconstant weeks-offset 2145)
 138 (defconstant seconds-offset 432000)
 139 (defconstant minutes-per-day (* 24 60))
 140 (defconstant quarter-days-per-year (1+ (* 365 4)))
 141 (defconstant quarter-days-per-century 146097)
 142 (defconstant november-17-1858 678882)
 143 (defconstant weekday-november-17-1858 2)
 144 (defconstant unix-to-universal-time 2208988800)
 145
 146 (defun get-universal-time ()
 147   #!+sb-doc
 148   "Return a single integer for the current time of
 149    day in universal time format."
 150   (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
 151     (declare (ignore res))
 152     (+ secs unix-to-universal-time)))
 153
 154 (defun get-decoded-time ()
 155   #!+sb-doc
 156   "Return nine values specifying the current time as follows:
 157    second, minute, hour, date, month, year, day of week (0 = Monday), T
 158    (daylight savings times) or NIL (standard time), and timezone."
 159   (decode-universal-time (get-universal-time)))
 160
 161 (defconstant +mar-1-2000+ #.(encode-universal-time 0 0 0 1 3 2000 0))
 162 (defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0))
 163
 164 (defconstant +mar-1-1903+ #.(encode-universal-time 0 0 0 1 3 1903 0))
 165
 166 (defun years-since-mar-2000 (utime)
 167   "Returns number of complete years since March 1st 2000, and remainder in seconds"
 168   (let* ((days-in-year (* 86400 365))
 169          (days-in-4year (+ (* 4 days-in-year) 86400))
 170          (days-in-100year (- (* 25 days-in-4year) 86400))
 171          (days-in-400year (+ (* 4 days-in-100year) 86400))
 172          (offset (- utime +mar-1-2000+))
 173          (year 0))
 174     (labels ((whole-num (x y inc max)
 175                (let ((w (truncate x y)))
 176                  (when (and max (> w max)) (setf w max))
 177                  (incf year (* w inc))
 178                  (* w y))))
 179       (decf offset (whole-num offset days-in-400year 400 nil))
 180       (decf offset (whole-num offset days-in-100year 100 3))
 181       (decf offset (whole-num offset days-in-4year 4 25))
 182       (decf offset (whole-num offset days-in-year 1 3))
 183       (values year offset))))
 184
 185 (defun truncate-to-unix-range (utime)
 186   (let ((unix-time (- utime unix-to-universal-time)))
 187     (cond
 188       ((< unix-time (- (ash 1 31)))
 189        (multiple-value-bind (year offset) (years-since-mar-2000 utime)
 190          (declare (ignore year))
 191          (+  +mar-1-1903+  (- unix-to-universal-time)  offset)))
 192       ((>= unix-time (ash 1 31))
 193        (multiple-value-bind (year offset) (years-since-mar-2000 utime)
 194          (declare (ignore year))
 195          (+  +mar-1-2035+  (- unix-to-universal-time)  offset)))
 196       (t unix-time))))
 197
 198 (defun decode-universal-time (universal-time &optional time-zone)
 199   #!+sb-doc
 200   "Converts a universal-time to decoded time format returning the following
 201    nine values: second, minute, hour, date, month, year, day of week (0 =
 202    Monday), T (daylight savings time) or NIL (standard time), and timezone.
 203    Completely ignores daylight-savings-time when time-zone is supplied."
 204   (multiple-value-bind (daylight seconds-west)
 205       (if time-zone
 206           (values nil (* time-zone 60 60))
 207           (multiple-value-bind (ignore seconds-west daylight)
 208               (sb!unix::get-timezone (truncate-to-unix-range universal-time))
 209             (declare (ignore ignore))
 210             (declare (fixnum seconds-west))
 211             (values daylight seconds-west)))
 212     (declare (fixnum seconds-west))
 213     (multiple-value-bind (weeks secs)
 214         (truncate (+ (- universal-time seconds-west) seconds-offset)
 215                   seconds-in-week)
 216       (let ((weeks (+ weeks weeks-offset)))
 217         (multiple-value-bind (t1 second)
 218             (truncate secs 60)
 219           (let ((tday (truncate t1 minutes-per-day)))
 220             (multiple-value-bind (hour minute)
 221                 (truncate (- t1 (* tday minutes-per-day)) 60)
 222               (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
 223                      (tcent (truncate t2 quarter-days-per-century)))
 224                 (setq t2 (mod t2 quarter-days-per-century))
 225                 (setq t2 (+ (- t2 (mod t2 4)) 3))
 226                 (let* ((year (+ (* tcent 100)
 227                                 (truncate t2 quarter-days-per-year)))
 228                        (days-since-mar0
 229                         (1+ (truncate (mod t2 quarter-days-per-year) 4)))
 230                        (day (mod (+ tday weekday-november-17-1858) 7))
 231                        (t3 (+ (* days-since-mar0 5) 456)))
 232                   (cond ((>= t3 1989)
 233                          (setq t3 (- t3 1836))
 234                          (setq year (1+ year))))
 235                   (multiple-value-bind (month t3)
 236                       (truncate t3 153)
 237                     (let ((date (1+ (truncate t3 5))))
 238                       (values second minute hour date month year day
 239                               daylight
 240                               (if daylight
 241                                   (1+ (/ seconds-west 60 60))
 242                                   (/ seconds-west 60 60))))))))))))))
 243
 244 (defun pick-obvious-year (year)
 245   (declare (type (mod 100) year))
 246   (let* ((current-year (nth-value 5 (get-decoded-time)))
 247          (guess (+ year (* (truncate (- current-year 50) 100) 100))))
 248     (declare (type (integer 1900 9999) current-year guess))
 249     (if (> (- current-year guess) 50)
 250         (+ guess 100)
 251         guess)))
 252
 253 (defun leap-years-before (year)
 254   (let ((years (- year 1901)))
 255     (+ (- (truncate years 4)
 256           (truncate years 100))
 257        (truncate (+ years 300) 400))))
 258
 259 (defvar *days-before-month*
 260   #.(let ((reversed-result nil)
 261           (sum 0))
 262       (push nil reversed-result)
 263       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
 264         (push sum reversed-result)
 265         (incf sum days-in-month))
 266       (coerce (nreverse reversed-result) 'simple-vector)))
 267
 268
 269 (defun encode-universal-time (second minute hour date month year
 270                                      &optional time-zone)
 271   #!+sb-doc
 272   "The time values specified in decoded format are converted to
 273    universal time, which is returned."
 274   (declare (type (mod 60) second)
 275            (type (mod 60) minute)
 276            (type (mod 24) hour)
 277            (type (integer 1 31) date)
 278            (type (integer 1 12) month)
 279            (type (or (integer 0 99) (integer 1899)) year)
 280            ;; that type used to say (integer 1900), but that's
 281            ;; incorrect when a time-zone is specified: we should be
 282            ;; able to encode to produce 0 when a non-zero timezone is
 283            ;; specified - bem, 2005-08-09
 284            (type (or null rational) time-zone))
 285   (let* ((year (if (< year 100)
 286                    (pick-obvious-year year)
 287                    year))
 288          (days (+ (1- date)
 289                   (aref *days-before-month* month)
 290                   (if (> month 2)
 291                       (leap-years-before (1+ year))
 292                       (leap-years-before year))
 293                   (* (- year 1900) 365)))
 294          (hours (+ hour (* days 24)))
 295          (encoded-time 0))
 296     (if time-zone
 297         (setf encoded-time (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)))
 298         (let* ((secwest-guess
 299                 (sb!unix::unix-get-seconds-west
 300                  (truncate-to-unix-range (* hours 60 60))))
 301                (guess (+ second (* 60 (+ minute (* hours 60)))
 302                          secwest-guess))
 303                (secwest
 304                 (sb!unix::unix-get-seconds-west
 305                  (truncate-to-unix-range guess))))
 306           (setf encoded-time (+ guess (- secwest secwest-guess)))))
 307     (assert (typep encoded-time '(integer 0)))
 308     encoded-time))
 309 \f
 310 ;;;; TIME
 311
 312 (defvar *gc-run-time* 0
 313   #!+sb-doc
 314   "the total CPU time spent doing garbage collection (as reported by
 315    GET-INTERNAL-RUN-TIME)")
 316 (declaim (type index *gc-run-time*))
 317
 318 (defmacro time (form)
 319   #!+sb-doc
 320   "Execute FORM and print timing information on *TRACE-OUTPUT*."
 321   `(%time (lambda () ,form)))
 322
 323 ;;; Return all the data that we want TIME to report.
 324 (defun time-get-sys-info ()
 325   (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
 326     (values user sys faults (get-bytes-consed))))
 327
 328 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
 329 ;;; function, report the times.
 330 (defun %time (fun)
 331   (declare (type function fun))
 332   (let (old-run-utime
 333         new-run-utime
 334         old-run-stime
 335         new-run-stime
 336         old-real-time
 337         new-real-time
 338         old-page-faults
 339         new-page-faults
 340         real-time-overhead
 341         run-utime-overhead
 342         run-stime-overhead
 343         page-faults-overhead
 344         old-bytes-consed
 345         new-bytes-consed
 346         cons-overhead)
 347     ;; Calculate the overhead...
 348     (multiple-value-setq
 349         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 350       (time-get-sys-info))
 351     ;; Do it a second time to make sure everything is faulted in.
 352     (multiple-value-setq
 353         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 354       (time-get-sys-info))
 355     (multiple-value-setq
 356         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 357       (time-get-sys-info))
 358     (setq run-utime-overhead (- new-run-utime old-run-utime))
 359     (setq run-stime-overhead (- new-run-stime old-run-stime))
 360     (setq page-faults-overhead (- new-page-faults old-page-faults))
 361     (setq old-real-time (get-internal-real-time))
 362     (setq old-real-time (get-internal-real-time))
 363     (setq new-real-time (get-internal-real-time))
 364     (setq real-time-overhead (- new-real-time old-real-time))
 365     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
 366     ;; Now get the initial times.
 367     (multiple-value-setq
 368         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 369       (time-get-sys-info))
 370     (setq old-real-time (get-internal-real-time))
 371     (let ((start-gc-run-time *gc-run-time*)
 372           #!+sb-eval (sb!eval:*eval-calls* 0))
 373       (declare #!+sb-eval (special sb!eval:*eval-calls*))
 374       (multiple-value-prog1
 375           ;; Execute the form and return its values.
 376           (funcall fun)
 377         (multiple-value-setq
 378             (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 379           (time-get-sys-info))
 380         (setq new-real-time (- (get-internal-real-time) real-time-overhead))
 381         (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
 382           (format *trace-output*
 383                   "~&Evaluation took:~%  ~
 384                  ~S second~:P of real time~%  ~
 385                  ~S second~:P of user run time~%  ~
 386                  ~S second~:P of system run time~%  ~
 387               ~@[[Run times include ~S second~:P GC run time.]~%  ~]~
 388               ~@[~S call~:P to %EVAL~%  ~]~
 389                  ~S page fault~:P and~%  ~
 390                  ~:D bytes consed.~%"
 391                   (max (/ (- new-real-time old-real-time)
 392                           (float sb!xc:internal-time-units-per-second))
 393                        0.0)
 394                   (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
 395                   (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
 396                   (unless (zerop gc-run-time)
 397                     (/ (float gc-run-time)
 398                        (float sb!xc:internal-time-units-per-second)))
 399                   #!+sb-eval sb!eval:*eval-calls* #!-sb-eval nil
 400                   (max (- new-page-faults old-page-faults) 0)
 401                   (max (- new-bytes-consed old-bytes-consed) 0)))))))
 402