diff --git a/code/exports.lisp b/code/exports.lisp index 8a6fce93487e4a66b411ff1a4d7f18788ae0296d..0d7f2fe9587e7b387bdfbed6f8c95761aeceb9e0 100644 --- a/code/exports.lisp +++ b/code/exports.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/exports.lisp,v 1.134 1997/12/13 16:47:47 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.135 1998/01/04 22:41:44 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1631,7 +1631,8 @@ "ENABLE-PROCESS" "INIT-STACK-GROUPS" "LOCK" "MAKE-STACK-GROUP" "MAKE-LOCK" "MAKE-PROCESS" "PROCESS-ACTIVE-P" "PROCESS-ALIVE-P" "PROCESS-INTERRUPT" "PROCESS-NAME" "PROCESS-PRESET" - "PROCESS-STATE" "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" + "PROCESS-STATE" "PROCESS-WAIT-UNTIL-FD-USABLE" + "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" "SHOW-PROCESSES" "STACK-GROUP-RESUME" "WITHOUT-SCHEDULING" "WITH-LOCK-HELD")) diff --git a/code/lispinit.lisp b/code/lispinit.lisp index fd592b21059c605c28f1b11eb44509a85d86d290..fbfa70a2a745e275541400a0b5eed0740e881e9d 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.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/lispinit.lisp,v 1.53 1997/11/21 12:16:28 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.54 1998/01/04 22:41:46 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -439,6 +439,7 @@ (throw '%end-of-the-world 0))) +#-mp ; Multi-processing version defined in multi-proc.lisp. (defun sleep (n) "This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number." diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp index 1e1daa916c77997a342e2d2a3fc6fb97d2dc314d..fbd1729fd3163b6d657e0b39cc2ae53a3678e4de 100644 --- a/code/multi-proc.lisp +++ b/code/multi-proc.lisp @@ -3,7 +3,7 @@ ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the Public domain, and is provided 'as is'. ;;; -;;; $Id: multi-proc.lisp,v 1.17 1998/01/03 03:18:57 dtc Exp $ +;;; $Id: multi-proc.lisp,v 1.18 1998/01/04 22:41:41 dtc Exp $ ;;; ;;; ********************************************************************** ;;; @@ -1306,6 +1306,100 @@ (pushnew 'scrub-all-processes-stacks ext:*before-gc-hooks*) +;;; Process-Wait-Until-FD-Usable -- Public. +;;; +;;; Wait until FD is usable for DIRECTION. +;;; +(defun process-wait-until-fd-usable (fd direction &optional timeout) + "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or + :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving + up." + (declare (type kernel:index fd) + (type (or real null) timeout) + (optimize (speed 3))) + (if (or (eq *current-process* *initial-process*) + ;; Can't call process-wait if the scheduling is inhibited. + *inhibit-scheduling*) + ;; The initial-process calls the event server to block. + (sys:wait-until-fd-usable fd direction timeout) + ;; Other processes use process-wait. + (flet ((fd-usable-for-input () + (declare (optimize (speed 3) (safety 1))) + (not (eql (alien:with-alien ((read-fds + (alien:struct unix:fd-set))) + (unix:fd-zero read-fds) + (unix:fd-set fd read-fds) + (unix:unix-fast-select + (1+ fd) (alien:addr read-fds) nil nil 0 0)) + 0))) + (fd-usable-for-output () + (declare (optimize (speed 3) (safety 1))) + (not (eql (alien:with-alien ((write-fds + (alien:struct unix:fd-set))) + (unix:fd-zero write-fds) + (unix:fd-set fd write-fds) + (unix:unix-fast-select + (1+ fd) nil (alien:addr write-fds) nil 0 0)) + 0)))) + + (ecase direction + (:input + (unless (fd-usable-for-input) + ;; Wait until input possible. + (sys:with-fd-handler (fd :input + #'(lambda (fd) + (declare (ignore fd) + (optimize (speed 3) + (safety 0))) + (mp:process-yield))) + (if timeout + (mp:process-wait-with-timeout "Input Wait" timeout + #'fd-usable-for-input) + (mp:process-wait "Input Wait" #'fd-usable-for-input))))) + (:output + (unless (fd-usable-for-output) + ;; Wait until output possible. + (sys:with-fd-handler (fd :output + #'(lambda (fd) + (declare (ignore fd) + (optimize (speed 3) + (safety 0))) + (mp:process-yield))) + (if timeout + (mp:process-wait-with-timeout "Output Wait" timeout + #'fd-usable-for-output) + (mp:process-wait "Output Wait" + #'fd-usable-for-output))))))))) + + +;;; Sleep -- Public +;;; +;;; Redefine the sleep function to call process-wait-with-timeout, +;;; rather than blocking. +;;; +(defun sleep (n) + "This function causes execution to be suspended for N seconds. N may + be any non-negative, non-complex number." + (when (or (not (realp n)) + (minusp n)) + (error "Invalid argument to SLEEP: ~S.~%~ + Must be a non-negative, non-complex number." + n)) + (cond ((or (eq *current-process* *initial-process*) + ;; Can't call process-wait if the scheduling is inhibited. + *inhibit-scheduling*) + ;; The initial-process may block. + (multiple-value-bind (sec usec) + (if (integerp n) + (values n 0) + (values (truncate n) + (truncate (* n 1000000)))) + (unix:unix-select 0 0 0 0 sec usec)) + nil) + (t + (process-wait-with-timeout "Sleep" n (constantly nil))))) + + ;;; Show-Processes ;;; (defun show-processes (&optional verbose)