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

Define a new function process-wait-until-fd-usable; similar to

sys:wait-until-fd-usable but uses process-wait so avoids blocking if
there are other runnable processes.

Redefine the sleep function to use process-wait-with-timeout to avoid
blocking if there are other runnable processes.
parent 55adbb2c
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/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"))
......@@ -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."
......
......@@ -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)
......
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