io-multiplex/time.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; time.lisp --- Various time-related functions.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :io.multiplex)
  25
  26 ;;;; Monotonic Time
  27
  28 #-(or darwin windows)
  29 (defun get-monotonic-time ()
  30   (multiple-value-bind (sec nsec)
  31       (nix:clock-gettime nix:clock-monotonic)
  32     (+ sec (/ nsec 1d9))))
  33
  34 ;;; No sure if GetTickCount() has all of the desired properties.
  35 ;;; Also, it'd be better to use GetTickCount64() but that's
  36 ;;; Vista-only.  So, FIXME: need to check for overflow.
  37 #+windows
  38 (progn
  39   (load-foreign-library "Kernel32.dll")
  40
  41   (defctype bool (:boolean :int))
  42   (defctype large-integer :int64)
  43
  44   (defcfun ("QueryPerformanceCounter" query-perf-counter :cconv :stdcall)
  45       bool
  46     (count :pointer))
  47
  48   (defun get-monotonic-time ()
  49     (with-foreign-object (ptr 'large-integer)
  50       (assert (query-perf-counter ptr))
  51       (mem-ref ptr 'large-integer))))
  52
  53 #+darwin
  54 (progn
  55   (defctype mach-kern-return :int)
  56   (defctype mach-clock-res :int)
  57   (defctype mach-clock-id :int)
  58   (defctype mach-port :unsigned-int) ; not sure
  59   (defctype mach-clock-serv mach-port)
  60
  61   (defconstant +mach-kern-success+ 0)
  62   (defconstant +mach-system-clock+ 0)
  63
  64   (defcstruct mach-timespec
  65     (tv-sec :unsigned-int)
  66     (tv-nsec mach-clock-res))
  67
  68   (defcfun "mach_host_self" mach-port)
  69
  70   (defcfun "host_get_clock_service" mach-kern-return
  71     (host mach-port)
  72     (id mach-clock-id)
  73     (clock-name (:pointer mach-clock-serv)))
  74
  75   (defcfun "clock_get_time" mach-kern-return
  76     (clock-serv mach-clock-serv)
  77     (cur-time mach-timespec))
  78
  79   (defun get-monotonic-time ()
  80     (with-foreign-object (clock 'mach-clock-serv)
  81       (host-get-clock-service (mach-host-self) +mach-system-clock+ clock)
  82       (with-foreign-object (time 'mach-timespec)
  83         (clock-get-time (mem-ref clock :int) time)
  84         (with-foreign-slots ((tv-sec tv-nsec) time mach-timespec)
  85           (+ tv-sec (/ tv-nsec 1d9)))))))
  86
  87 ;;;; Timeouts
  88
  89 (deftype timeout ()
  90   'double-float)
  91
  92 ;;; Break a real timeout into seconds and microseconds.
  93 (defun decode-timeout (timeout)
  94   (typecase timeout
  95     (integer (values timeout 0))
  96     (null    nil)
  97     (real
  98      (multiple-value-bind (q r) (truncate (coerce timeout 'double-float))
  99        (declare (type unsigned-byte q)
 100                 (type double-float r))
 101        (values q (the (values unsigned-byte t) (truncate (* r 1d6))))))
 102     (t
 103      (error "Timeout is not a real number or NIL: ~S" timeout))))
 104
 105 (defun normalize-timeout (timeout)
 106   (when timeout
 107     (assert (not (minusp timeout)))
 108     (etypecase timeout
 109       ((or integer real) (coerce timeout 'double-float)))))
 110
 111 (defun abs-timeout (timeout)
 112   (when timeout
 113     (+ (get-monotonic-time) (normalize-timeout timeout))))
 114
 115 (defun calc-min-timeout (t1 t2)
 116   (if t1
 117       (if t2
 118           (min t1 t2)
 119           t1)
 120       t2))