source: trunk/source/lib/time.lisp @ 14423

Last change on this file since 14423 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(eval-when (:compile-toplevel :execute)
21  (defconstant seconds-in-week (* 60 60 24 7))
22  (defconstant weeks-offset 2145)
23  (defconstant seconds-offset 432000)
24  (defconstant minutes-per-day (* 24 60))
25  (defconstant quarter-days-per-year (1+ (* 365 4)))
26  (defconstant quarter-days-per-century 146097)
27  (defconstant november-17-1858 678882)
28  (defconstant weekday-november-17-1858 2)
29)
30
31(defun gctime ()
32  (let* ((timeval-size (record-length :timeval)))
33    (%stack-block ((copy (* timeval-size 5)))
34      (#_memmove copy *total-gc-microseconds* (* timeval-size 5))
35      (macrolet ((funk (arg)
36                   (ecase internal-time-units-per-second 
37                    (1000000 `(timeval->microseconds ,arg))
38                    (1000 `(timeval->milliseconds ,arg)))))
39        (values
40         (funk copy)
41         (funk (%incf-ptr copy timeval-size))
42         (funk (%incf-ptr copy timeval-size))
43         (funk (%incf-ptr copy timeval-size))
44         (funk (%incf-ptr copy timeval-size)))))))
45
46
47
48
49;;; This should stop using #_localtime_r: not all times can be represented
50;;; as a signed natural offset from the start of Unix time.
51;;; For now, if the time won't fit in a :time_t, use an arbitrary time
52;;; value to get the time zone and assume that DST was -not- in effect.
53#-windows-target
54(defun get-timezone (time)
55  (let* ((toobig (not (typep time '(signed-byte
56                                    #+32-bit-target 32
57                                    #+64-bit-target 64)))))
58    (when toobig
59      (setq time 0))
60    (rlet ((when :time_t)
61           (tm :tm))
62      (setf (pref when :time_t) time)
63      (with-macptrs ((ltm (#_localtime_r when tm)))
64        (if (%null-ptr-p ltm)
65          (values 0 nil)
66          (progn
67            (values (floor #-solaris-target (pref tm :tm.tm_gmtoff)
68                           #+solaris-target #&altzone
69                           -60)
70                    (unless toobig (not (zerop (pref tm :tm.tm_isdst)))))))))))
71
72#+windows-target
73(defun get-timezone (time)
74  (declare (ignore time))
75  (rlet ((tzinfo #>TIME_ZONE_INFORMATION))
76    (let* ((id (#_GetTimeZoneInformation tzinfo))
77           (minutes-west (pref tzinfo #>TIME_ZONE_INFORMATION.Bias))
78           (is-dst (= id #$TIME_ZONE_ID_DAYLIGHT)))
79      (values (floor (+ minutes-west
80                        (if is-dst
81                          (pref tzinfo #>TIME_ZONE_INFORMATION.DaylightBias)
82                          0)))
83              is-dst))))
84
85
86
87(defun decode-universal-time (universal-time &optional time-zone)
88  "Converts a universal-time to decoded time format returning the following
89   nine values: second, minute, hour, date, month, year, day of week (0 =
90   Monday), T (daylight savings time) or NIL (standard time), and timezone.
91   Completely ignores daylight-savings-time when time-zone is supplied."
92  (multiple-value-bind (weeks secs)
93                       (truncate (+ universal-time seconds-offset)
94                                 seconds-in-week)
95    (let* ((weeks (+ weeks weeks-offset))
96           (second NIL)
97           (minute NIL)
98           (hour NIL)
99           (date NIL)
100           (month NIL)
101           (year NIL)
102           (day NIL)
103           (daylight NIL)
104           (timezone (if (null time-zone)
105                         (multiple-value-bind
106                             (minwest dst)
107                             (get-timezone (- universal-time
108                                              unix-to-universal-time))
109                           (setf daylight dst)
110                           minwest)
111                         (* time-zone 60))))
112      (declare (fixnum timezone))
113      (multiple-value-bind (t1 seconds) (truncate secs 60)
114        (setq second seconds)
115        (setq t1 (- t1 timezone))
116        (let* ((tday (if (< t1 0)
117                         (1- (truncate (1+ t1) minutes-per-day))
118                         (truncate t1 minutes-per-day))))
119          (multiple-value-setq (hour minute)
120            (truncate (- t1 (* tday minutes-per-day)) 60))
121          (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
122                 (tcent (truncate t2 quarter-days-per-century)))
123            (setq t2 (mod t2 quarter-days-per-century))
124            (setq t2 (+ (- t2 (mod t2 4)) 3))
125            (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
126            (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
127                                                 4))))
128              (setq day (mod (+ tday weekday-november-17-1858) 7))
129              (let ((t3 (+ (* days-since-mar0 5) 456)))
130                (cond ((>= t3 1989)
131                       (setq t3 (- t3 1836))
132                       (setq year (1+ year))))
133                (multiple-value-setq (month t3) (truncate t3 153))
134                (setq date (1+ (truncate t3 5))))))))
135      (values second minute hour date month year day
136              daylight
137              (if daylight
138                  (1+ (/ timezone 60))
139                  (/ timezone 60))))))
140
141(defun get-decoded-time ()
142  "Return nine values specifying the current time as follows:
143   second, minute, hour, date, month, year, day of week (0 = Monday), T
144   (daylight savings times) or NIL (standard time), and timezone."
145  (decode-universal-time (get-universal-time)))
146
147(defun current-year ()
148  (nth-value 5 (get-decoded-time)))
149
150(defun leap-years-before (year)
151  (let ((years (- year 1901)))
152    (+ (- (truncate years 4)
153          (truncate years 100))
154       (truncate (+ years 300) 400))))
155
156(defvar *days-before-month*
157  (let* ((results (list nil)))
158    (let ((sum 0))
159      (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
160        (push sum results)
161        (incf sum days-per-month)))
162    (coerce (nreverse results) 'vector)))
163
164(defun encode-universal-time (second minute hour date month year
165                                     &optional time-zone)
166  "The time values specified in decoded format are converted to
167   universal time, which is returned."
168  (declare (type (mod 60) second)
169           (type (mod 60) minute)
170           (type (mod 24) hour)
171           (type (integer 1 31) date)
172           (type (integer 1 12) month)
173           (type unsigned-byte year)
174           (type (or null rational) time-zone))
175  (when (< year 100)
176    (let* ((this (current-year))
177           (past (- this 50))
178           (future (+ this 49))
179           (maybe-past (+ (- past (mod past 100)) year))
180           (maybe-future (+ (- future (mod future 100)) year)))
181      (if (>= maybe-past past)
182        (setq year maybe-past)
183        (setq year maybe-future))))
184           
185  (let* ((days (+ (1- date)
186                  (aref *days-before-month* month)
187                  (if (> month 2)
188                    (leap-years-before (1+ year))
189                    (leap-years-before year))
190                  (* (- year 1900) 365)))
191         (hours (+ hour (* days 24))))
192    (if time-zone
193      (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
194      (let* ((minwest-guess
195              (get-timezone (- (* hours 60 60)
196                               unix-to-universal-time)))
197             (guess (+ minute (* hours 60) minwest-guess))
198             (minwest
199              (get-timezone (- (* guess 60)
200                               unix-to-universal-time))))
201        (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
202
203
204#+windows-target
205(defun %windows-sleep (millis)
206  (do* ((start (floor (get-internal-real-time)
207                      (floor internal-time-units-per-second 1000))
208               (floor (get-internal-real-time)
209                      (floor internal-time-units-per-second 1000)))
210        (millis millis (- stop start))
211        (stop (+ start millis)))
212       ((or (<= millis 0)
213            (not (eql (#_SleepEx millis #$true) #$WAIT_IO_COMPLETION))))))
214
215(defun sleep (seconds)
216  "This function causes execution to be suspended for N seconds. N may
217  be any non-negative, non-complex number."
218  (when (minusp seconds) (report-bad-arg seconds '(real 0 *)))
219  #-windows-target
220  (multiple-value-bind (secs nanos)
221      (nanoseconds seconds)
222    (%nanosleep secs nanos))
223  #+windows-target
224  (%windows-sleep (round (* seconds 1000))))
225
226
227(defun %internal-run-time ()
228  ;; Returns user and system times in internal-time-units as multiple values.
229  #-windows-target
230  (rlet ((usage :rusage))
231    (%%rusage usage)
232    (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec))
233           (system-seconds (pref usage :rusage.ru_stime.tv_sec))
234           (user-micros (pref usage :rusage.ru_utime.tv_usec))
235           (system-micros (pref usage :rusage.ru_stime.tv_usec)))
236      (values (+ (* user-seconds internal-time-units-per-second)
237                 (round user-micros (floor 1000000 internal-time-units-per-second)))
238              (+ (* system-seconds internal-time-units-per-second)
239                 (round system-micros (floor 1000000 internal-time-units-per-second))))))
240  #+windows-target
241  (rlet ((start #>FILETIME)
242         (end #>FILETIME)
243         (kernel #>FILETIME)
244         (user #>FILETIME))
245    (#_GetProcessTimes (#_GetCurrentProcess) start end kernel user)
246    (let* ((user-100ns (dpb (pref user #>FILETIME.dwHighDateTime)
247                            (byte 32 32)
248                            (pref user #>FILETIME.dwLowDateTime)))
249           (kernel-100ns (dpb (pref kernel #>FILETIME.dwHighDateTime)
250                            (byte 32 32)
251                            (pref kernel #>FILETIME.dwLowDateTime)))
252           (convert (floor 10000000 internal-time-units-per-second)))
253      (values (floor user-100ns convert) (floor kernel-100ns convert)))))
254
255(defun get-internal-run-time ()
256  "Return the run time in the internal time format. (See
257  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage."
258  (multiple-value-bind (user sys) (%internal-run-time)
259    (+ user sys)))
260
261
262
263
264
265     
Note: See TracBrowser for help on using the repository browser.