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))

--=-=-=--