From: Aleksandr Skobelev
Subject: Timers for serve-event. Was: Socket Programming
Date:
Message-ID: <m1wu3966mn.fsf@askomac.add.com>
--=-=-=
For some reasons I have no ability to post any message in c.l.l for
several days. So all my previous posts with timer facility addition to
the serve-event, which I mentioned in the Socket Programming thread were
lost. But it looks like all is fixed now. So I do a yet another attempt.
-----------------------------------------------------------------------
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. My main concern is how it all will works in multithreaded
environment. 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))
--=-=-=--