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. (See
  31   INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time."
  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. (See
  51   INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for 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 ;;; In August 2003, work was done in this file for more plausible
  74 ;;; timezone handling after the unix timezone database runs out in
  75 ;;; 2038.  We assume that timezone rules are trending sane rather than
  76 ;;; insane, so for all years after the end of time_t we apply the
  77 ;;; rules for 2035/2036 instead of the actual date asked for.  Making
  78 ;;; the same assumption about the early 1900s would be less
  79 ;;; reasonable, however, so please note that we're still broken for
  80 ;;; local time between 1900-1-1 and 1901-12-13
  81
  82 ;;; It should be noted that 64 bit machines don't actually fix this
  83 ;;; problem, at least as of 2003, because the Unix zonefiles are
  84 ;;; specified in terms of 32 bit fields even on, say, the Alpha.  So,
  85 ;;; references to the range of time_t elsewhere in this file should
  86 ;;; rightly be read as shorthand for the range of an signed 32 bit
  87 ;;; number of seconds since 1970-01-01
  88
  89 ;;; I'm obliged to Erik Naggum's "Long, Painful History of Time" paper
  90 ;;; <http://heim.ifi.uio.no/~enag/lugm-time.html> for the choice of epoch
  91 ;;; here.  By starting the year in March, we avoid having to test the month
  92 ;;; whenever deciding whether to account for a leap day.  2000 is especially
  93 ;;; special, because it's disvisible by 400, hence the start of a 400 year
  94 ;;; leap year cycle
  95
  96 ;;; If a universal-time is after time_t runs out, we find its offset
  97 ;;; from 1st March of whichever year it falls in, then add that to
  98 ;;; 2035-3-1.  This date has two relevant properties: (1) somewhere
  99 ;;; near the end of time_t, and (2) preceding a leap year.  Thus a
 100 ;;; date which is e.g. 365.5 days from March 1st in its year will be
 101 ;;; treated for timezone lookup as if it were Feb 29th 2036
 102
 103 ;;; This epoch is used only for fixing the timezones-outside-time_t
 104 ;;; problem.  Someday it would be nice to come back to this code and
 105 ;;; see if the rest of the file and its references to Spice Lisp
 106 ;;; history (Perq time base?) could be cleaned up any on this basis.
 107 ;;; -- dan, 2003-08-08
 108
 109
 110 ;;; Subtract from the returned Internal-Time to get the universal
 111 ;;; time. The offset between our time base and the Perq one is 2145
 112 ;;; weeks and five days.
 113 (defconstant seconds-in-week (* 60 60 24 7))
 114 (defconstant weeks-offset 2145)
 115 (defconstant seconds-offset 432000)
 116 (defconstant minutes-per-day (* 24 60))
 117 (defconstant quarter-days-per-year (1+ (* 365 4)))
 118 (defconstant quarter-days-per-century 146097)
 119 (defconstant november-17-1858 678882)
 120 (defconstant weekday-november-17-1858 2)
 121 (defconstant unix-to-universal-time 2208988800)
 122
 123 (defun get-universal-time ()
 124   #!+sb-doc
 125   "Return a single integer for the current time of
 126    day in universal time format."
 127   (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
 128     (declare (ignore res))
 129     (+ secs unix-to-universal-time)))
 130
 131 (defun get-decoded-time ()
 132   #!+sb-doc
 133   "Return nine values specifying the current time as follows:
 134    second, minute, hour, date, month, year, day of week (0 = Monday), T
 135    (daylight savings times) or NIL (standard time), and timezone."
 136   (decode-universal-time (get-universal-time)))
 137
 138 (defconstant +mar-1-2000+ #.(encode-universal-time 0 0 0 1 3 2000 0))
 139 (defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0))
 140
 141 (defun years-since-mar-2000 (utime)
 142   "Returns number of complete years since March 1st 2000, and remainder in seconds"
 143   (let* ((days-in-year (* 86400 365))
 144          (days-in-4year (+ (* 4 days-in-year) 86400))
 145          (days-in-100year (- (* 25 days-in-4year) 86400))
 146          (days-in-400year (+ (* 4 days-in-100year) 86400))
 147          (offset (- utime +mar-1-2000+))
 148          (year 0))
 149     (labels ((whole-num (x y inc max)
 150                (let ((w (truncate x y)))
 151                  (when (and max (> w max)) (setf w max))
 152                  (incf year (* w inc))
 153                  (* w y))))
 154       (decf offset (whole-num offset days-in-400year 400 nil))
 155       (decf offset (whole-num offset days-in-100year 100 3))
 156       (decf offset (whole-num offset days-in-4year 4 25))
 157       (decf offset (whole-num offset days-in-year 1 3))
 158       (values year offset))))
 159
 160 (defun truncate-to-unix-range (utime)
 161   (let ((unix-time (- utime unix-to-universal-time)))
 162     (if (< unix-time (ash 1 31))
 163         unix-time
 164         (multiple-value-bind (year offset) (years-since-mar-2000 utime)
 165           (+  +mar-1-2035+  (- unix-to-universal-time)  offset)))))
 166
 167 (defun decode-universal-time (universal-time &optional time-zone)
 168   #!+sb-doc
 169   "Converts a universal-time to decoded time format returning the following
 170    nine values: second, minute, hour, date, month, year, day of week (0 =
 171    Monday), T (daylight savings time) or NIL (standard time), and timezone.
 172    Completely ignores daylight-savings-time when time-zone is supplied."
 173   (multiple-value-bind (weeks secs)
 174       (truncate (+ universal-time seconds-offset)
 175                 seconds-in-week)
 176     (let* ((weeks (+ weeks weeks-offset))
 177            (second NIL)
 178            (minute NIL)
 179            (hour NIL)
 180            (date NIL)
 181            (month NIL)
 182            (year NIL)
 183            (day NIL)
 184            (daylight NIL)
 185            (timezone (cond
 186                        ((null time-zone)
 187                         (multiple-value-bind (ignore minwest dst)
 188                             (sb!unix::get-timezone
 189                              (truncate-to-unix-range universal-time))
 190                           (declare (ignore ignore))
 191                           (declare (fixnum minwest))
 192                           (setf daylight dst)
 193                           minwest))
 194                        (t (* time-zone 60)))))
 195       (declare (fixnum timezone))
 196       (multiple-value-bind (t1 seconds) (truncate secs 60)
 197         (setq second seconds)
 198         (setq t1 (- t1 timezone))
 199         (let* ((tday (if (< t1 0)
 200                          (1- (truncate (1+ t1) minutes-per-day))
 201                          (truncate t1 minutes-per-day))))
 202           (multiple-value-setq (hour minute)
 203             (truncate (- t1 (* tday minutes-per-day)) 60))
 204           (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
 205                  (tcent (truncate t2 quarter-days-per-century)))
 206             (setq t2 (mod t2 quarter-days-per-century))
 207             (setq t2 (+ (- t2 (mod t2 4)) 3))
 208             (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
 209             (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
 210                                                  4))))
 211               (setq day (mod (+ tday weekday-november-17-1858) 7))
 212               (let ((t3 (+ (* days-since-mar0 5) 456)))
 213                 (cond ((>= t3 1989)
 214                        (setq t3 (- t3 1836))
 215                        (setq year (1+ year))))
 216                 (multiple-value-setq (month t3) (truncate t3 153))
 217                 (setq date (1+ (truncate t3 5))))))))
 218       (values second minute hour date month year day
 219               daylight
 220               (if daylight
 221                   (1+ (/ timezone 60))
 222                   (/ timezone 60))))))
 223
 224 (defun pick-obvious-year (year)
 225   (declare (type (mod 100) year))
 226   (let* ((current-year (nth-value 5 (get-decoded-time)))
 227          (guess (+ year (* (truncate (- current-year 50) 100) 100))))
 228     (declare (type (integer 1900 9999) current-year guess))
 229     (if (> (- current-year guess) 50)
 230         (+ guess 100)
 231         guess)))
 232
 233 (defun leap-years-before (year)
 234   (let ((years (- year 1901)))
 235     (+ (- (truncate years 4)
 236           (truncate years 100))
 237        (truncate (+ years 300) 400))))
 238
 239 (defvar *days-before-month*
 240   #.(let ((reversed-result nil)
 241           (sum 0))
 242       (push nil reversed-result)
 243       (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
 244         (push sum reversed-result)
 245         (incf sum days-in-month))
 246       (coerce (nreverse reversed-result) 'simple-vector)))
 247
 248
 249 (defun encode-universal-time (second minute hour date month year
 250                                      &optional time-zone)
 251   #!+sb-doc
 252   "The time values specified in decoded format are converted to
 253    universal time, which is returned."
 254   (declare (type (mod 60) second)
 255            (type (mod 60) minute)
 256            (type (mod 24) hour)
 257            (type (integer 1 31) date)
 258            (type (integer 1 12) month)
 259            (type (or (integer 0 99) (integer 1900)) year)
 260            (type (or null rational) time-zone))
 261   (let* ((year (if (< year 100)
 262                    (pick-obvious-year year)
 263                    year))
 264          (days (+ (1- date)
 265                   (aref *days-before-month* month)
 266                   (if (> month 2)
 267                       (leap-years-before (1+ year))
 268                       (leap-years-before year))
 269                   (* (- year 1900) 365)))
 270          (hours (+ hour (* days 24))))
 271     (if time-zone
 272         (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
 273         ;; can't ask unix for times after 2037: this is only a problem
 274         ;; if we need to query the system timezone
 275         (if (> year 2037)
 276             (labels ((leap-year-p (year)
 277                        (cond ((zerop (mod year 400)) t)
 278                              ((zerop (mod year 100)) t)
 279                              ((zerop (mod year 4)) t)
 280                              (t nil))))
 281               (let* ((fake-year (if (leap-year-p year) 2036 2037))
 282                      (fake-time (encode-universal-time second minute hour
 283                                                        date month fake-year)))
 284                 (+ fake-time
 285                    (* 86400 (+ (* 365 (- year fake-year))
 286                                (- (leap-years-before year)
 287                                   (leap-years-before fake-year)))))))
 288             (let* ((minwest-guess
 289                     (sb!unix::unix-get-minutes-west
 290                      (- (* hours 60 60) unix-to-universal-time)))
 291                    (guess (+ minute (* hours 60) minwest-guess))
 292                    (minwest
 293                     (sb!unix::unix-get-minutes-west
 294                      (- (* guess 60) unix-to-universal-time))))
 295               (+ second (* (+ guess (- minwest minwest-guess)) 60)))))))
 296 \f
 297 ;;;; TIME
 298
 299 (defmacro time (form)
 300   #!+sb-doc
 301   "Execute FORM and print timing information on *TRACE-OUTPUT*."
 302   `(%time (lambda () ,form)))
 303
 304 ;;; Return all the data that we want TIME to report.
 305 (defun time-get-sys-info ()
 306   (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
 307     (values user sys faults (get-bytes-consed))))
 308
 309 ;;; The guts of the TIME macro. Compute overheads, run the (compiled)
 310 ;;; function, report the times.
 311 (defun %time (fun)
 312   (declare (type function fun))
 313   (let (old-run-utime
 314         new-run-utime
 315         old-run-stime
 316         new-run-stime
 317         old-real-time
 318         new-real-time
 319         old-page-faults
 320         new-page-faults
 321         real-time-overhead
 322         run-utime-overhead
 323         run-stime-overhead
 324         page-faults-overhead
 325         old-bytes-consed
 326         new-bytes-consed
 327         cons-overhead)
 328     ;; Calculate the overhead...
 329     (multiple-value-setq
 330         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 331       (time-get-sys-info))
 332     ;; Do it a second time to make sure everything is faulted in.
 333     (multiple-value-setq
 334         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 335       (time-get-sys-info))
 336     (multiple-value-setq
 337         (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 338       (time-get-sys-info))
 339     (setq run-utime-overhead (- new-run-utime old-run-utime))
 340     (setq run-stime-overhead (- new-run-stime old-run-stime))
 341     (setq page-faults-overhead (- new-page-faults old-page-faults))
 342     (setq old-real-time (get-internal-real-time))
 343     (setq old-real-time (get-internal-real-time))
 344     (setq new-real-time (get-internal-real-time))
 345     (setq real-time-overhead (- new-real-time old-real-time))
 346     (setq cons-overhead (- new-bytes-consed old-bytes-consed))
 347     ;; Now get the initial times.
 348     (multiple-value-setq
 349         (old-run-utime old-run-stime old-page-faults old-bytes-consed)
 350       (time-get-sys-info))
 351     (setq old-real-time (get-internal-real-time))
 352     (let ((start-gc-run-time *gc-run-time*))
 353     (multiple-value-prog1
 354         ;; Execute the form and return its values.
 355         (funcall fun)
 356       (multiple-value-setq
 357           (new-run-utime new-run-stime new-page-faults new-bytes-consed)
 358         (time-get-sys-info))
 359       (setq new-real-time (- (get-internal-real-time) real-time-overhead))
 360       (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
 361         (format *trace-output*
 362                 "~&Evaluation took:~%  ~
 363                  ~S second~:P of real time~%  ~
 364                  ~S second~:P of user run time~%  ~
 365                  ~S second~:P of system run time~%  ~
 366 ~@[                 [Run times include ~S second~:P GC run time.]~%  ~]~
 367                  ~S page fault~:P and~%  ~
 368                  ~S bytes consed.~%"
 369                 (max (/ (- new-real-time old-real-time)
 370                         (float sb!xc:internal-time-units-per-second))
 371                      0.0)
 372                 (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
 373                 (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
 374                 (unless (zerop gc-run-time)
 375                   (/ (float gc-run-time)
 376                      (float sb!xc:internal-time-units-per-second)))
 377                 (max (- new-page-faults old-page-faults) 0)
 378                 (max (- new-bytes-consed old-bytes-consed) 0)))))))