;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;; Copyright 1994-2009 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package "CCL")

(eval-when (:compile-toplevel :execute)
  (defconstant seconds-in-week (* 60 60 24 7))
  (defconstant weeks-offset 2145)
  (defconstant seconds-offset 432000)
  (defconstant minutes-per-day (* 24 60))
  (defconstant quarter-days-per-year (1+ (* 365 4)))
  (defconstant quarter-days-per-century 146097)
  (defconstant november-17-1858 678882)
  (defconstant weekday-november-17-1858 2)
)

(defun gctime ()
  (let* ((timeval-size (record-length :timeval)))
    (%stack-block ((copy (* timeval-size 5)))
      (#_memmove copy *total-gc-microseconds* (* timeval-size 5))
      (macrolet ((funk (arg)
                   (ecase internal-time-units-per-second 
                    (1000000 `(timeval->microseconds ,arg))
                    (1000 `(timeval->milliseconds ,arg)))))
        (values
         (funk copy)
         (funk (%incf-ptr copy timeval-size))
         (funk (%incf-ptr copy timeval-size))
         (funk (%incf-ptr copy timeval-size))
         (funk (%incf-ptr copy timeval-size)))))))




;;; This should stop using #_localtime_r: not all times can be represented
;;; as a signed natural offset from the start of Unix time.
;;; For now, if the time won't fit in a :time_t, use an arbitrary time
;;; value to get the time zone and assume that DST was -not- in effect.
#-windows-target
(defun get-timezone (time)
  (let* ((toobig (not (typep time '(signed-byte
                                    #+32-bit-target 32
                                    #+64-bit-target 64)))))
    (when toobig
      (setq time 0))
    (rlet ((when :time_t)
           (tm :tm))
      (setf (pref when :time_t) time)
      (with-macptrs ((ltm (#_localtime_r when tm)))
        (if (%null-ptr-p ltm)
          (values 0 nil)
          (progn
            (values (floor #-solaris-target (pref tm :tm.tm_gmtoff)
                           #+solaris-target #&altzone
                           -60)
                    (unless toobig (not (zerop (pref tm :tm.tm_isdst)))))))))))

;; Use #_localtime to determine if DST was in effect for the supplied time
;; but use #_GetTimeZoneInformation to get the DST bias as Windows' struct tm
;; doesn't include the time's timezone offset as it does on Unix.
;; Again, as in the Unix version, if the given time won't fit as a signed offset
;; from the base time, use the base time and assume DST was not in effect.
#+windows-target
(defun get-timezone (time)
  (let* ((toobig (not (typep time '(signed-byte
                                    #+32-bit-target 32
                                    #+64-bit-target 64)))))
    (when toobig
      (setq time 0))
    (rlet ((when :time_t)
           (tzinfo #>TIME_ZONE_INFORMATION))
      (setf (pref when :time_t) time)
      (with-macptrs ((tm (#_localtime when)))
        (if (%null-ptr-p tm)
          (values 0 nil)
          (let* ((id (#_GetTimeZoneInformation tzinfo))
                 (minutes-west (pref tzinfo #>TIME_ZONE_INFORMATION.Bias))
                 (is-dst (and (not toobig) (not (zerop (pref tm :tm.tm_isdst))))))
            (declare (ignore id))
            (values (floor (+ minutes-west
                              (if is-dst
                                  (pref tzinfo #>TIME_ZONE_INFORMATION.DaylightBias)
                                  0)))
                    is-dst)))))))



(defun decode-universal-time (universal-time &optional time-zone)
  "Converts a universal-time to decoded time format returning the following
   nine values: second, minute, hour, date, month, year, day of week (0 =
   Monday), T (daylight savings time) or NIL (standard time), and timezone.
   Completely ignores daylight-savings-time when time-zone is supplied."
  (let* ((daylight nil)
         (timezone (if (null time-zone)
                     (multiple-value-bind
                         (minwest dst)
                         (get-timezone (- universal-time
                                          unix-to-universal-time))
                       (declare (fixnum minwest))
                       (setf daylight dst)
                       (the fixnum (* minwest 60)))
                     (* time-zone 60 60))))
    (declare (fixnum timezone))
    (multiple-value-bind (weeks secs)
        (truncate (+ (- universal-time timezone) seconds-offset)
                  seconds-in-week)
      (let* ((weeks (+ weeks weeks-offset))
             (second NIL)
             (minute NIL)
             (hour NIL)
             (date NIL)
             (month NIL)
             (year NIL)
             (day NIL))
        (multiple-value-bind (t1 seconds) (truncate secs 60)
          (setq second seconds)
          (let* ((tday (truncate t1 minutes-per-day)))
            (multiple-value-setq (hour minute)
              (truncate (- t1 (* tday minutes-per-day)) 60))
            (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
                   (tcent (truncate t2 quarter-days-per-century)))
              (setq t2 (mod t2 quarter-days-per-century))
              (setq t2 (+ (- t2 (mod t2 4)) 3))
              (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
                                                   4))))
                (setq day (mod (+ tday weekday-november-17-1858) 7))
                (let ((t3 (+ (* days-since-mar0 5) 456)))
                  (cond ((>= t3 1989)
                         (setq t3 (- t3 1836))
                         (setq year (1+ year))))
                  (multiple-value-setq (month t3) (truncate t3 153))
                  (setq date (1+ (truncate t3 5))))))))
        (values second minute hour date month year day
                daylight
                (if daylight
		  (1+ (/ timezone 60 60))
		  (/ timezone 60 60)))))))

(defun get-decoded-time ()
  "Return nine values specifying the current time as follows:
   second, minute, hour, date, month, year, day of week (0 = Monday), T
   (daylight savings times) or NIL (standard time), and timezone."
  (decode-universal-time (get-universal-time)))

(defun current-year ()
  (nth-value 5 (get-decoded-time)))

(defun leap-years-before (year)
  (let ((years (- year 1901)))
    (+ (- (truncate years 4)
	  (truncate years 100))
       (truncate (+ years 300) 400))))

(defvar *days-before-month*
  (let* ((results (list nil)))
    (let ((sum 0))
      (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
	(push sum results)
	(incf sum days-per-month)))
    (coerce (nreverse results) 'vector)))

(defun check-valid-date (year month day)
  (declare (fixnum year month day))
  (let* ((limit (if (and (eql month 2)
                         (not (logtest year 3))
                         (or (eql 0 (mod year 400))
                             (not (eql 0 (mod year 100)))))
                  29
                  (svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)))))
    (declare (fixnum limit))
    (unless (<= day limit)
      (report-bad-arg day `(integer 1 ,limit)))))

(defun encode-universal-time (second minute hour date month year
				     &optional (time-zone nil tz-p))
  "The time values specified in decoded format are converted to
   universal time, which is returned."
  (check-type second (mod 60))
  (check-type minute (mod 60))
  (check-type hour (mod 24))
  (check-type date (integer 1 31))
  (check-type month (integer 1 12))
  (check-type year unsigned-byte)
  (when time-zone
    (check-type time-zone (rational -24 24)))
  (locally
      (declare (type (mod 60) second)
               (type (mod 60) minute)
               (type (mod 24) hour)
               (type (integer 1 31) date)
               (type (integer 1 12) month)
               (type unsigned-byte year)
               (type (or null rational) time-zone))
    (when (< year 100)
      (let* ((this (current-year))
             (past (- this 50))
             (future (+ this 49))
             (maybe-past (+ (- past (mod past 100)) year))
             (maybe-future (+ (- future (mod future 100)) year)))
        (if (>= maybe-past past)
          (setq year maybe-past)
          (setq year maybe-future))))
    ;; 12/31/1899 in some time zones might yield a date after
    ;; the start of the epoch in UTC.
    (check-type year (integer 1899))
    (check-valid-date year month date)
    (let* ((days (+ (1- date)
                    (aref *days-before-month* month)
                    (if (> month 2)
                      (leap-years-before (1+ year))
                      (leap-years-before year))
                    (* (- year 1900) 365)))
           (hours (+ hour (* days 24)))
           (result
            (if time-zone
              (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
              (let* ((minwest-guess
                      (get-timezone (- (* hours 60 60)
                                       unix-to-universal-time)))
                     (guess (+ minute (* hours 60) minwest-guess))
                     (minwest
                      (get-timezone (- (* guess 60)
                                       unix-to-universal-time))))
                (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
      (if (< result 0)
        (error "Universal time for MM/DD/YYYY ~2,'0d/~2,'0d/~4,'0d ~2,'0d:~2,'0d:~2,'0d ~%with ~a time zone would be negative." month date year hour minute second (if tz-p "specified" "current"))
        result))))


#+windows-target
(defun %windows-sleep (millis)
  (do* ((start (floor (get-internal-real-time)
                      (floor internal-time-units-per-second 1000))
               (floor (get-internal-real-time)
                      (floor internal-time-units-per-second 1000)))
        (millis millis (- stop start))
        (stop (+ start millis)))
       ((or (<= millis 0)
            (not (eql (#_SleepEx millis #$true) #$WAIT_IO_COMPLETION))))))

(defun sleep (seconds)
  "This function causes execution to be suspended for N seconds. N may
  be any non-negative, non-complex number."
  (when (minusp seconds) (report-bad-arg seconds '(real 0 *)))
  #-windows-target
  (multiple-value-bind (secs nanos)
      (nanoseconds seconds)
    (%nanosleep secs nanos))
  #+windows-target
  (%windows-sleep (round (* seconds 1000))))


(defun %internal-run-time ()
  ;; Returns user and system times in internal-time-units as multiple values.
  #-windows-target
  (rlet ((usage :rusage))
    (%%rusage usage)
    (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec))
           (system-seconds (pref usage :rusage.ru_stime.tv_sec))
           (user-micros (pref usage :rusage.ru_utime.tv_usec))
           (system-micros (pref usage :rusage.ru_stime.tv_usec)))
      (values (+ (* user-seconds internal-time-units-per-second)
                 (round user-micros (floor 1000000 internal-time-units-per-second)))
              (+ (* system-seconds internal-time-units-per-second)
                 (round system-micros (floor 1000000 internal-time-units-per-second))))))
  #+windows-target
  (rlet ((start #>FILETIME)
         (end #>FILETIME)
         (kernel #>FILETIME)
         (user #>FILETIME))
    (#_GetProcessTimes (#_GetCurrentProcess) start end kernel user)
    (let* ((user-100ns (dpb (pref user #>FILETIME.dwHighDateTime)
                            (byte 32 32)
                            (pref user #>FILETIME.dwLowDateTime)))
           (kernel-100ns (dpb (pref kernel #>FILETIME.dwHighDateTime)
                            (byte 32 32)
                            (pref kernel #>FILETIME.dwLowDateTime)))
           (convert (floor 10000000 internal-time-units-per-second)))
      (values (floor user-100ns convert) (floor kernel-100ns convert)))))

(defun get-internal-run-time ()
  "Return the run time in the internal time format. (See
  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage."
  (multiple-value-bind (user sys) (%internal-run-time)
    (+ user sys)))

#-(or darwin-target windows-target)
(defloadvar preferred-posix-clock-id
  (rlet ((ts :timespec))
    (if (eql 0 (#_clock_gettime #$CLOCK_MONOTONIC ts))
      #$CLOCK_MONOTONIC
      #$CLOCK_REALTIME)))    

(defun current-time-in-nanoseconds ()
  #-(or darwin-target windows-target)
  (rlet ((ts :timespec))
    (#_clock_gettime preferred-posix-clock-id ts)
    (+ (* (pref ts :timespec.tv_sec) 1000000000)
       (pref ts :timespec.tv_nsec)))
  #+darwin-target (#_mach_absolute_time)
  #+windows-target
  (rlet ((time #>FILETIME))
    (#_GetSystemTimeAsFileTime time)
    (* (logior (pref time #>FILETIME.dwLowDateTime)
               (ash (pref time #>FILETIME.dwHighDateTime) 32))
       100)))

