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

Last change on this file since 10829 was 10829, checked in by gb, 11 years ago

Sleep interruptably/continuably on Windows.

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