From: Aleksandr Skobelev
Subject: Timers for serve-event. was: socket programming
Date:
Message-ID: <m1n047wigx.fsf@askomac.add.com>
--=-=-=
It looks like my followup in "Socket programming" was lost. So I'm trying
again.
Below are the attached files serve-event.patch and serve-timer.lisp. The
first contains a patch for serve-event.lisp file from code directory in
the CMUCL's source tree. The second is realization of the facility.
Just load serve-timer.lisp and then serve-event.lisp patched with
serve-event.patch. Be ware that serve-timer.lisp file has to be loaded
before the patched serve-event.lisp file.
The patch just adds calls to the ext::adjust-timeout and
ext::serve-timers functions from serve-timer.lisp into the
sub-serve-event function.
It seems to me that this code is working :), but I wrote it a more then
year ago and didn't use it only for writing simple code snippet from CLM
manual.
So, any comments/patches are welcome.
--=-=-=
Content-Type: text/x-patch
Content-Disposition: attachment; filename=serve-event.patch
--- serve-event.lisp Fri May 14 12:14:58 2004
+++ serve-event-patched.lisp Wed May 12 13:54:20 2004
@@ -5,7 +5,7 @@
@@ -471,6 +470,9 @@
(setf to-usec *max-event-to-usec*)
(setf call-polling-fn t))
+ (multiple-value-bind (ts tu) (ext::adjust-timeout to-sec to-usec)
+ (setf to-sec ts to-usec tu))
+
;; Next, wait for something to happen.
(alien:with-alien ((read-fds (alien:struct unix:fd-set))
(write-fds (alien:struct unix:fd-set)))
@@ -484,6 +486,7 @@
;; Now see what it was (if anything)
(cond (value
+ (ext::serve-timers)
(cond ((zerop value)
;; Timed out.
(when call-polling-fn
--=-=-=
Content-Type: application/octet-stream
Content-Disposition: attachment; filename=serve-timer.lisp
(in-package "EXT")
(export '(add-timer remove-timer start-timer stop-timer set-interval))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
#+(and)
(defun declare-opt (&rest decls)
`(declare (optimize (speed 3) (space 0) (debug 1) (safety 0))
,@decls))
#-(and)
(defun declare-opt (&rest decls)
`(declare (optimize (speed 0) (space 0) (debug 3) (safety 3))
,@decls))
) ;;eval-when
;; (declaim (start-block add-timer remove-timer
;; start-timer stop-timer set-interval
;; serve-timers adjust-timeout))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declaim (inline get-time))
(defun get-time ()
(declare (values (signed-byte 32) (signed-byte 32)))
(multiple-value-bind (e s u) (unix:unix-gettimeofday)
(declare (ignore e))
(values s u)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declaim (inline time-norm))
(defun time-norm (sec usec)
#.(declare-opt '(type integer sec usec)
'(values (signed-byte 32) (mod 1000000)))
(unless (<= 0 usec 999999)
(multiple-value-bind (s u) (floor usec 1000000)
(setf sec (+ sec s) usec u)))
(if (< sec 0)
(values 0 0)
(if (< #x7fffffff sec)
(values #x7fffffff usec)
(values sec usec))))
(declaim (inline time+))
(defun time+ (v1-sec v1-usec v2-sec v2-usec)
#.(declare-opt '(type (signed-byte 32) v1-sec v2-sec)
'(type (mod 1000000) v1-usec v2-usec)
'(values (signed-byte 32) (mod 1000000)))
(time-norm (+ v1-sec v2-sec) (+ v1-usec v2-usec)))
(declaim (inline time-))
(defun time- (v1-sec v1-usec v2-sec v2-usec)
#.(declare-opt '(type (signed-byte 32) v1-sec v2-sec)
'(type (mod 1000000) v1-usec v2-usec)
'(values (unsigned-byte 32) (mod 1000000)))
(time-norm (- v1-sec v2-sec) (- v1-usec v2-usec)))
(declaim (inline time<))
(defun time< (v1-sec v1-usec v2-sec v2-usec)
#.(declare-opt '(type (signed-byte 32) v1-sec v2-sec)
'(type (mod 1000000) v1-usec v2-usec)
'(values boolean))
(or (< v1-sec v2-sec)
(and (= v1-sec v2-sec) (< v1-usec v2-usec))))
(declaim (inline interval-norm))
(defun interval-norm (interval-ms)
#.(declare-opt '(type integer interval-ms)
'(values (signed-byte 32) (mod 1000000)))
(multiple-value-bind (s m) (floor interval-ms 1000)
(time-norm s (* m 1000))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (defparameter *log* "/tmp/serve-timer.log")
;; (defun printlog (fmt &rest args)
;; (with-open-file (log *log* :direction ':output :if-exists ':append
;; :if-does-not-exist ':create)
;; (multiple-value-bind (e s u) (unix:unix-gettimeofday)
;; (declare (ignore e))
;; (multiple-value-bind (sc mn hr)
;; (decode-universal-time (+ 2208988800 s))
;; (apply #'format log
;; (concatenate 'string "~&<~2,'0D:~2,'0D:~2,'0D.~3,'0D> " fmt "~%")
;; hr mn sc (truncate u 1000)
;; args)))
;; (force-output log)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *next-id* 0)
(defparameter *timers* nil
"The plist of all timers.")
(defparameter *active-timers* nil
"The list of active timers that will be handled by SERVE-TIMERS.
The elements in this list are represented as (TIMER-ID SEC USEC) list, where
SEC and USEC is an absolute time as UNIX:UNIX-GETTIMEOFDAY gives it,
when the timer procedure has to be run.")
(defparameter *current-timer* nil
"Set to a current timer during the timer handling")
(defstruct (timer);; (:print-function print-timer))
(id (incf *next-id*) :type (unsigned-byte 32))
(isec 0 :type (signed-byte 32))
(iusec 0 :type (signed-byte 32))
(once-p nil :type boolean)
(active-p nil :type boolean)
(remove-p nil :type boolean)
handler
data)
(defun print-timer (timer stream level)
(declare (ignore level))
(print-unreadable-object
(timer stream :type t :identity t)
(format stream "ID: ~D INTERVAL: ~D.~3,'0D HANDLER: ~S"
(timer-id timer)
(timer-isec timer)
(truncate (timer-iusec timer) 1000)
(timer-handler timer))))
(declaim (inline %get-timer))
(defun %get-timer (id)
(getf *timers* id))
(declaim (inline %set-timer))
(defun %set-timer (timer)
(setf (getf *timers* (timer-id timer)) timer)
(timer-id timer))
(declaim (inline %del-timer))
(defun %del-timer (id)
(remf *timers* id))
(declaim (inline %activate-timers))
(defun %activate-timer (timer sec usec)
#.(declare-opt)
(let ((tm (list (timer-id timer) sec usec)))
(flet ((tm< (l r)
(time< (cadr l) (caddr l) (cadr r) (caddr r))))
(setf *active-timers* (merge 'list *active-timers* (list tm) #'tm<)
(timer-active-p timer) t))))
(declaim (inline %desactivate-timers))
(defun %disactivate-timer (timer)
#.(declare-opt)
(setf (timer-active-p timer) nil
*active-timers* (delete (timer-id timer) *active-timers* :key #'car)))
(defun add-timer (interval-ms
handler client-data
&key (active t) (once nil) (remove nil))
#.(declare-opt)
(check-type interval-ms (integer 0 *) "a positive integer")
(multiple-value-bind (ns nu) (get-time)
(multiple-value-bind (is iu) (interval-norm interval-ms)
(multiple-value-bind (sc us) (time+ ns nu is iu)
(let* ((tm (make-timer :isec is :iusec iu
:once-p once
:remove-p remove
:handler handler
:data client-data)))
(%set-timer tm)
(when active (%activate-timer tm sc us))
(timer-id tm))))))
(defun remove-timer (timer-id)
#.(declare-opt)
(let ((tm (%get-timer timer-id)))
(when tm
(%disactivate-timer tm)
(%del-timer timer-id))))
(defun stop-timer (timer-id)
#.(declare-opt)
(let ((tm (%get-timer timer-id)))
(when tm
(%disactivate-timer tm)
(when (timer-remove-p tm) (%del-timer timer-id)))))
;;How to start / stop a timer from a handler?
(defun start-timer (timer-id &optional (interval-ms))
#.(declare-opt)
(check-type interval-ms (or nil (integer 0 *)) "a NIL or positive integer")
(let ((tm (%get-timer timer-id)))
(when tm
(when (timer-active-p tm)
(cerror "Stop timer #~D" "Starting activated timer #~D"
timer-id)
(stop-timer timer-id))
(multiple-value-bind (ns nu) (get-time)
(when interval-ms
(multiple-value-bind (is iu) (interval-norm interval-ms)
(setf (timer-isec tm) is (timer-iusec tm) iu)))
(multiple-value-bind (sc us)
(time+ ns nu (timer-isec tm) (timer-iusec tm))
(%activate-timer tm sc us)))
timer-id)))
(defun set-timer-interval (timer-id interval-ms)
#.(declare-opt)
(check-type interval-ms integer)
(let ((tm (%get-timer timer-id)))
(when tm
(multiple-value-bind (is iu) (interval-norm interval-ms)
(setf (timer-isec tm) is (timer-iusec tm) iu))
timer-id)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun adjust-timeout (to-sec to-usec)
(let ((ti (car *active-timers*)))
(if (and ti (not *current-timer*)) ;;to prevent recursive timers handling
(multiple-value-bind (ns nu) (get-time)
(multiple-value-bind (ds du) (time- (cadr ti) (caddr ti) ns nu)
(if (time< ds du to-sec to-usec)
(values ds du)
(values to-sec to-usec))))
(values to-sec to-usec))))
(defun serve-timers ()
(let ((ti (car *active-timers*)))
(when (and ti (not *current-timer*)) ;;to prevent recursive timers handling
(let ((tid (car ti))
(tsc (cadr ti))
(tus (caddr ti)))
(multiple-value-bind (ns nu) (get-time)
;;(printlog "(serve-timers)")
(when (time< ns nu tsc tus) (return-from serve-timers)))
(setf *active-timers* (cdr *active-timers*))
(let ((tm (%get-timer tid)))
(when (and tm (timer-active-p tm))
(if (timer-once-p tm)
(setf (timer-active-p tm) nil)
(multiple-value-bind (ts-next tu-next)
(time+ tsc tus (timer-isec tm) (timer-iusec tm))
(%activate-timer tm ts-next tu-next)))
(ext:letf ((*current-timer* tm))
(handler-bind
((error
#'(lambda (c)
(%disactivate-timer tm)
(error c))))
;;(printlog "(serve-timers): will call handler for ~S" tm)
(funcall (timer-handler tm) tid (timer-data tm))
(when (and (not (timer-active-p tm)) (timer-remove-p tm))
(%del-timer tid))))
))))))
;; (declaim (end-block))
--=-=-=--