From c39be568024910b2dccf143390e8da99e9a030c0 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 29 Dec 1997 19:01:36 +0000
Subject: [PATCH] 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.

---
 code/serve-event.lisp | 73 ++++++++++++++++++++++++++++++-------------
 1 file changed, 51 insertions(+), 22 deletions(-)

diff --git a/code/serve-event.lisp b/code/serve-event.lisp
index 8d5152f64..9b4ea039c 100644
--- a/code/serve-event.lisp
+++ b/code/serve-event.lisp
@@ -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)))))))
 
-- 
GitLab