Skip to content
Snippets Groups Projects
Commit c39be568 authored by dtc's avatar dtc
Browse files

Add support for the periodic calling of a function when the event

server is waiting. This is used with the MP support to periodically
call process-yield.
parent 5b0b3520
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.22 1994/10/31 04:11:27 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.23 1997/12/29 19:01:36 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -439,33 +439,62 @@
); eval-when (compile eval)
;;; When a *periodic-polling-function* is defined the server will not
;;; block for more than the maximum event timeout and will call the
;;; polling function if it does times out. One important use of this
;;; is to periodically call process-yield.
;;;
(declaim (type (or null function) *periodic-polling-function*))
(defvar *periodic-polling-function*
#-mp nil #+mp #'mp:process-yield)
(declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
(defvar *max-event-to-sec* 1)
(defvar *max-event-to-usec* 0)
;;; SUB-SERVE-EVENT -- Internal
;;;
;;; Takes timeout broken into seconds and microseconds.
;;;
(defun sub-serve-event (to-sec to-usec)
(declare (type (or null (unsigned-byte 29)) to-sec to-usec))
(when (handle-queued-clx-event) (return-from sub-serve-event t))
;; Next, wait for something to happen.
(alien:with-alien ((read-fds (alien:struct unix:fd-set))
(write-fds (alien:struct unix:fd-set)))
(let ((count (calc-masks)))
(multiple-value-bind
(value err)
(unix:unix-fast-select
count
(alien:addr read-fds) (alien:addr write-fds)
nil to-sec to-usec)
(let ((call-polling-fn nil))
(when (and *periodic-polling-function*
;; Enforce a maximum timeout.
(or (null to-sec)
(> to-sec *max-event-to-sec*)
(and (= to-sec *max-event-to-sec*)
(> to-usec *max-event-to-usec*))))
(setf to-sec *max-event-to-sec*)
(setf to-usec *max-event-to-usec*)
(setf call-polling-fn t))
;; Next, wait for something to happen.
(alien:with-alien ((read-fds (alien:struct unix:fd-set))
(write-fds (alien:struct unix:fd-set)))
(let ((count (calc-masks)))
(multiple-value-bind
(value err)
(unix:unix-fast-select
count
(alien:addr read-fds) (alien:addr write-fds)
nil to-sec to-usec)
;; Now see what it was (if anything)
(cond (value
(unless (zerop value) (call-fd-handler)))
((eql err unix:eintr)
;; We did an interrupt.
t)
(t
;; One of the file descriptors is bad.
(handler-descriptors-error)
nil))))))
;; Now see what it was (if anything)
(cond (value
(cond ((zerop value)
;; Timed out.
(when call-polling-fn
(funcall *periodic-polling-function*)))
(t
(call-fd-handler))))
((eql err unix:eintr)
;; We did an interrupt.
t)
(t
;; One of the file descriptors is bad.
(handler-descriptors-error)
nil)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment