From 4186d8575f8e35c70e1b885eb3ed11f84a7618c3 Mon Sep 17 00:00:00 2001 From: dlichteblau Date: Sun, 31 Dec 2006 15:42:40 +0000 Subject: [PATCH] Use Bordeaux Threads for all threading primitives, so that non-GUI parts of Closure don't have to depend on CLIM anymore. - Removed all mp/ functions from glisp. - Use condition variables instead of process-wait. --- INSTALL | 5 +++-- closure.asd | 3 ++- src/glisp/dep-acl.lisp | 42 -------------------------------------- src/glisp/dep-clisp.lisp | 51 ---------------------------------------------- src/glisp/dep-cmucl.lisp | 38 +--------------------------------- src/glisp/dep-gcl.lisp | 9 -------- src/glisp/dep-openmcl.lisp | 35 ------------------------------- src/glisp/dep-sbcl.lisp | 36 -------------------------------- src/glisp/dep-scl.lisp | 38 +--------------------------------- src/glisp/package.lisp | 2 -- src/gui/clim-gui.lisp | 15 +++++++++++--- src/gui/clue-gui.lisp | 2 +- src/gui/dce-and-pce.lisp | 37 +++++++++++++++++---------------- src/html/html-style.lisp | 6 +++--- src/net/ftp.lisp | 4 ++-- src/net/http.lisp | 12 +++++------ src/renderer/document.lisp | 47 ++++++++++++++++++++++++++---------------- 17 files changed, 80 insertions(+), 302 deletions(-) diff --git a/INSTALL b/INSTALL index dd50786..5ffb89d 100644 --- a/INSTALL +++ b/INSTALL @@ -17,10 +17,11 @@ Provide yourself with: [Debian package gif2png] - 4. McCLIM, Closure XML, and their dependencies + 4. McCLIM, Closure XML, Bordeaux Threads, and their dependencies [ http://common-lisp.net/project/mcclim/ - http://common-lisp.net/project/cxml/ ] + http://common-lisp.net/project/cxml/ + http://common-lisp.net/project/bordeaux-threads/ ] Compile closure using ASDF: Register closure.asd in your central diff --git a/closure.asd b/closure.asd index 39ecef9..923d650 100644 --- a/closure.asd +++ b/closure.asd @@ -86,7 +86,8 @@ (asdf:defsystem closure :depends-on (:clim :clim-clx - :glisp) + :glisp + :bordeaux-threads) :default-component-class closure-source-file :components ((:module src diff --git a/src/glisp/dep-acl.lisp b/src/glisp/dep-acl.lisp index 3dd9e95..ba92f5e 100644 --- a/src/glisp/dep-acl.lisp +++ b/src/glisp/dep-acl.lisp @@ -29,14 +29,6 @@ (export 'glisp::read-byte-sequence :glisp) (export 'glisp::read-char-sequence :glisp) (export 'glisp::run-unix-shell-command :glisp) -(export 'glisp::mp/process-run-function :glisp) -(export 'glisp::mp/process-kill :glisp) -(export 'glisp::mp/seize-lock :glisp) -(export 'glisp::mp/release-lock :glisp) -(export 'glisp::mp/transfer-lock-owner :glisp) -(export 'glisp::mp/current-process :glisp) -(export 'glisp::mp/process-yield :glisp) -(export 'glisp::mp/process-wait :glisp) (export 'glisp::getenv :glisp) (defun glisp::read-byte-sequence (&rest ap) @@ -67,13 +59,6 @@ ) ||# -(defun glisp::mp/make-lock (&key name) - (mp:make-process-lock :name name)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(mp:with-process-lock (,lock) - ,@body)) - (defmacro glisp::with-timeout ((&rest options) &body body) `(mp:with-timeout ,options . ,body)) @@ -83,32 +68,5 @@ (defun glisp:run-unix-shell-command (cmd) (excl:shell cmd)) -(defun glisp:mp/process-run-function (name fn &rest args) - (apply #'mp:process-run-function name fn args)) - -(defun glisp:mp/process-kill (proc) - (mp:process-kill proc)) - -(defun glisp:mp/current-process () - sys:*current-process*) - -(defun glisp::mp/seize-lock (lock &key whostate) - whostate - (mp:process-lock lock)) - -(defun glisp::mp/transfer-lock-owner (lock old-process new-process) - (assert (eql (mp:process-lock-locker lock) old-process)) - (setf (mp:process-lock-locker lock) new-process) - ) - -(defun glisp::mp/release-lock (lock) - (mp:process-unlock lock)) - -(defun glisp::mp/process-yield (&optional process-to-run) - (mp:process-allow-schedule process-to-run)) - -(defun glisp::mp/process-wait (whostate predicate) - (mp:process-wait whostate predicate)) - (defun glisp::getenv (string) (sys:getenv string)) diff --git a/src/glisp/dep-clisp.lisp b/src/glisp/dep-clisp.lisp index 7ebb9ce..6924683 100644 --- a/src/glisp/dep-clisp.lisp +++ b/src/glisp/dep-clisp.lisp @@ -123,54 +123,3 @@ (export 'glisp::getenv :glisp) (defun glisp::getenv (var) (sys::getenv var)) - - - -(export 'glisp::mp/process-run-function :glisp) -(defun glisp:mp/process-run-function (name fn &rest args) - (apply #'mp:process-run-function name fn args)) - -(export 'glisp::mp/process-kill :glisp) -(defun glisp:mp/process-kill (proc) - (mp:process-kill proc)) - -(export 'glisp::mp/current-process :glisp) -(defun glisp:mp/current-process () - (mp:current-process)) - -(export 'glisp::mp/seize-lock :glisp) -(defun glisp::mp/seize-lock (lock &key whostate) - whostate - (mp:process-lock lock)) - -(export 'glisp::mp/release-lock :glisp) -(defun glisp::mp/release-lock (lock) - (mp:process-unlock lock)) - -(export 'glisp::mp/process-yield :glisp) -(defun glisp::mp/process-yield (&optional process-to-run) - process-to-run - (mp:process-allow-schedule)) - -(export 'glisp::mp/process-wait :glisp) -(defun glisp::mp/process-wait (whostate predicate) - (mp::process-wait whostate predicate)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(mp:with-process-lock (,lock) - ,@body)) - -(defun glisp::mp/make-lock (&key name) - (mp:make-process-lock :name name)) - - - - - - - - - - - - diff --git a/src/glisp/dep-cmucl.lisp b/src/glisp/dep-cmucl.lisp index 24b58b0..85faa66 100644 --- a/src/glisp/dep-cmucl.lisp +++ b/src/glisp/dep-cmucl.lisp @@ -192,7 +192,7 @@ Its result type is: On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from: target:code/run-program.lisp Created: Saturday, 6/20/98 07:13:08 pm [-1] - Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/dep-cmucl.lisp,v 1.3 2006-12-31 12:14:36 dlichteblau Exp $ + Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/dep-cmucl.lisp,v 1.4 2006-12-31 15:42:40 dlichteblau Exp $ ||# ;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil)) @@ -200,41 +200,5 @@ target:code/run-program.lisp (defun glisp:run-unix-shell-command (command) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil))) -;;; MP - -(export 'glisp::mp/process-yield :glisp) -(export 'glisp::mp/process-wait :glisp) -(export 'glisp::mp/process-run-function :glisp) -(export 'glisp::mp/make-lock :glisp) -(export 'glisp::mp/current-process :glisp) -(export 'glisp::mp/process-kill :glisp) - -(defun glisp::mp/make-lock (&key name) - (mp:make-lock name)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(mp:with-lock-held (,lock) - ,@body)) - -(defun glisp::mp/process-yield (&optional process-to-run) - (declare (ignore process-to-run)) - (mp:process-yield)) - -(defun glisp::mp/process-wait (whostate predicate) - (mp:process-wait whostate predicate)) - -(defun glisp::mp/process-run-function (name fun &rest args) - (mp:make-process - (lambda () - (apply fun args)) - :name name)) - -(defun glisp::mp/current-process () - mp:*current-process*) - -(defun glisp::mp/process-kill (process) - (mp:destroy-process process)) - (defun glisp::getenv (string) (cdr (assoc string ext:*environment-list* :test #'string-equal))) - diff --git a/src/glisp/dep-gcl.lisp b/src/glisp/dep-gcl.lisp index aa860b9..265b5e3 100644 --- a/src/glisp/dep-gcl.lisp +++ b/src/glisp/dep-gcl.lisp @@ -100,15 +100,6 @@ index) value)) -(defun glisp::mp/make-lock (&key name) - name - nil) - -(defmacro glisp::mp/with-lock ((lock) &body body) - (declare (ignore lock)) - `(progn - ,@body)) - (defmacro glisp::with-timeout ((&rest ignore) &body body) (declare (ignore ignore)) `(progn diff --git a/src/glisp/dep-openmcl.lisp b/src/glisp/dep-openmcl.lisp index d453ca4..b953d47 100644 --- a/src/glisp/dep-openmcl.lisp +++ b/src/glisp/dep-openmcl.lisp @@ -145,41 +145,6 @@ Xref: mu list.closure-devel:8 (ccl:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))) -;;; MP - -(export 'glisp::mp/process-yield :glisp) -(export 'glisp::mp/process-wait :glisp) -(export 'glisp::mp/process-run-function :glisp) -(export 'glisp::mp/make-lock :glisp) -(export 'glisp::mp/current-process :glisp) -(export 'glisp::mp/process-kill :glisp) - -(defun glisp::mp/make-lock (&key name) - (clim-sys::make-lock name)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(clim-sys:with-lock-held (,lock) - ,@body)) - -(defun glisp::mp/process-yield (&optional process-to-run) - (declare (ignore process-to-run)) - (clim-sys:process-yield)) - -(defun glisp::mp/process-wait (whostate predicate) - (clim-sys:process-wait whostate predicate)) - -(defun glisp::mp/process-run-function (name fun &rest args) - (clim-sys:make-process - (lambda () - (apply fun args)) - :name name)) - -(defun glisp::mp/current-process () - (clim-sys:current-process)) - -(defun glisp::mp/process-kill (process) - (clim-sys:destroy-process process)) - (defun glisp::getenv (string) (ccl::getenv string))  \ No newline at end of file diff --git a/src/glisp/dep-sbcl.lisp b/src/glisp/dep-sbcl.lisp index a488981..f1cedfd 100644 --- a/src/glisp/dep-sbcl.lisp +++ b/src/glisp/dep-sbcl.lisp @@ -100,41 +100,5 @@ (sb-ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil))) -;;; MP - -(export 'glisp::mp/process-yield :glisp) -(export 'glisp::mp/process-wait :glisp) -(export 'glisp::mp/process-run-function :glisp) -(export 'glisp::mp/make-lock :glisp) -(export 'glisp::mp/current-process :glisp) -(export 'glisp::mp/process-kill :glisp) - -(defun glisp::mp/make-lock (&key name) - (clim-sys::make-lock name)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(clim-sys:with-lock-held (,lock) - ,@body)) - -(defun glisp::mp/process-yield (&optional process-to-run) - (declare (ignore process-to-run)) - (clim-sys:process-yield)) - -(defun glisp::mp/process-wait (whostate predicate) - (clim-sys:process-wait whostate predicate)) - -(defun glisp::mp/process-run-function (name fun &rest args) - (clim-sys:make-process - (lambda () - (apply fun args)) - :name name)) - -(defun glisp::mp/current-process () - (clim-sys:current-process)) - -(defun glisp::mp/process-kill (process) - (clim-sys:destroy-process process)) - (defun glisp::getenv (string) (sb-ext:posix-getenv string)) - diff --git a/src/glisp/dep-scl.lisp b/src/glisp/dep-scl.lisp index 6ec1d2e..173528a 100644 --- a/src/glisp/dep-scl.lisp +++ b/src/glisp/dep-scl.lisp @@ -161,7 +161,7 @@ Its result type is: On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from: target:code/run-program.lisp Created: Saturday, 6/20/98 07:13:08 pm [-1] - Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/dep-scl.lisp,v 1.1 2006-12-31 13:11:44 dlichteblau Exp $ + Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/dep-scl.lisp,v 1.2 2006-12-31 15:42:40 dlichteblau Exp $ ||# ;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil)) @@ -172,41 +172,5 @@ target:code/run-program.lisp ;;; MP -(export 'glisp::mp/process-yield :glisp) -(export 'glisp::mp/process-wait :glisp) -(export 'glisp::mp/process-run-function :glisp) -(export 'glisp::mp/make-lock :glisp) -(export 'glisp::mp/current-process :glisp) -(export 'glisp::mp/process-kill :glisp) - -(defun glisp::mp/make-lock (&key name) - (pthread::make-lock name)) - -(defmacro glisp::mp/with-lock ((lock) &body body) - `(pthread::with-lock-held (,lock) - ,@body)) - -(defun glisp::mp/process-yield (&optional process-to-run) - (declare (ignore process-to-run)) - (PTHREAD:SCHED-YIELD)) - -(defun glisp::mp/process-wait (whostate predicate) - (do () - ((funcall predicate)) - (sleep .1))) - -(defun glisp::mp/process-run-function (name fun &rest args) - (pthread::thread-create - (lambda () - (apply fun args)) - :name name)) - -(defun glisp::mp/current-process () - 'blah) - -(defun glisp::mp/process-kill (process) - (warn "*** Define GLISP:MP/PROCESS-KILL for CMUCL.")) - (defun glisp::getenv (string) (cdr (assoc string ext:*environment-list* :test #'string-equal))) - diff --git a/src/glisp/package.lisp b/src/glisp/package.lisp index 6a1126d..ca3133a 100644 --- a/src/glisp/package.lisp +++ b/src/glisp/package.lisp @@ -32,8 +32,6 @@ (:use :cl) (:export "DEFSUBST" "G/MAKE-STRING" - "MP/MAKE-LOCK" - "MP/WITH-LOCK" "WITH-TIMEOUT" "OPEN-INET-SOCKET" ;; util.lisp : diff --git a/src/gui/clim-gui.lisp b/src/gui/clim-gui.lisp index 17fc939..ae721e4 100644 --- a/src/gui/clim-gui.lisp +++ b/src/gui/clim-gui.lisp @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.26 2006-12-31 13:26:23 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.27 2006-12-31 15:42:40 dlichteblau Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,7 +28,16 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ -;; Revision 1.26 2006-12-31 13:26:23 emarsden +;; Revision 1.27 2006-12-31 15:42:40 dlichteblau +;; +;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of +;; Closure don't have to depend on CLIM anymore. +;; +;; - Removed all mp/ functions from glisp. +;; +;; - Use condition variables instead of process-wait. +;; +;; Revision 1.26 2006/12/31 13:26:23 emarsden ;; - add basic wholine support (currently title & last-modified information) ;; - add "TeX mode On" and "TeX mode Off" commands (experimental) ;; @@ -445,7 +454,7 @@ (defmacro with-closure (ignore &body body) (declare (ignore ignore)) - `(clim-sys:with-lock-held (*closure-lock*) + `(clim-sys:with-recursive-lock-held (*closure-lock*) ,@body)) (defun parse-url* (url) diff --git a/src/gui/clue-gui.lisp b/src/gui/clue-gui.lisp index adfd434..1e43b8d 100644 --- a/src/gui/clue-gui.lisp +++ b/src/gui/clue-gui.lisp @@ -41,7 +41,7 @@ (in-package :clue-gui2) (defparameter *dcache* nil) -(defparameter *dcache-lock* (mp/make-lock :name "dcache")) +(defparameter *dcache-lock* (bordeaux-threads:make-lock "dcache")) (defparameter *pixmap-cache* nil) diff --git a/src/gui/dce-and-pce.lisp b/src/gui/dce-and-pce.lisp index b480af5..91960dc 100644 --- a/src/gui/dce-and-pce.lisp +++ b/src/gui/dce-and-pce.lisp @@ -47,27 +47,28 @@ &key lazy-p callback) (let ((url (if (url:url-p url) (url:unparse-url url) url))) (let* ((dce - (mp/with-lock (*dcache-lock*) + (bordeaux-threads:with-recursive-lock-held (*dcache-lock*) (or (find-if (lambda (el) (and (equal (dce-url el) url) (eq (dce-presentation el) presentation))) *dcache*) - (let ((new-dce (make-dce :url url - :presentation presentation - :data :work-in-progress - :lock (mp/make-lock :name "dce lock"))) - (flag nil)) - (r2::run-process-on-behalf-of-document - document - (lambda () - (mp/with-lock ((dce-lock new-dce)) - (setf flag t) - (setf (dce-data new-dce) - (dcache-generate-presentation presentation document url)) ))) - (mp/process-wait "foo" - (lambda () flag)) - (push new-dce *dcache*) + (let* ((lock (bordeaux-threads:make-lock "dce lock")) + (new-dce (make-dce :url url + :presentation presentation + :data :work-in-progress + :lock lock)) + (flag (bordeaux-threads:make-condition-variable))) + (bordeaux-threads:with-recursive-lock-held (lock) + (r2::run-process-on-behalf-of-document + document + (lambda () + (bordeaux-threads:with-recursive-lock-held (lock) + (bordeaux-threads:condition-notify flag) + (setf (dce-data new-dce) + (dcache-generate-presentation presentation document url)) ))) + (bordeaux-threads:condition-wait flag lock) + (push new-dce *dcache*)) new-dce))))) (if lazy-p (progn @@ -75,10 +76,10 @@ document (lambda () (funcall callback - (mp/with-lock ((dce-lock dce)) + (bordeaux-threads:with-recursive-lock-held ((dce-lock dce)) (dce-data dce))))) nil) - (mp/with-lock ((dce-lock dce)) + (bordeaux-threads:with-recursive-lock-held ((dce-lock dce)) (dce-data dce)) )))) (defmethod dcache-generate-presentation ((presentation (eql :aimage)) document url) diff --git a/src/html/html-style.lisp b/src/html/html-style.lisp index 4991f37..2ad025b 100644 --- a/src/html/html-style.lisp +++ b/src/html/html-style.lisp @@ -378,13 +378,13 @@ (make-hash-table :test #'equalp)) (defparameter *style-sheet-cache*/lock - (mp/make-lock :name "*style-sheet-cache*")) + (bordeaux-threads:make-lock "*style-sheet-cache*")) (defun maybe-parse-style-sheet-from-url (url &key (name "anonymous") (supersheet nil) (media-type :all)) (multiple-value-bind (looked presentp) - (mp/with-lock (*style-sheet-cache*/lock) + (bordeaux-threads:with-recursive-lock-held (*style-sheet-cache*/lock) (gethash url *style-sheet-cache*)) (cond (presentp (format *debug-io* "~&;; Serving style sheet ~S [at ~S] from cache.~%" @@ -398,7 +398,7 @@ :name name :supersheet supersheet :media-type media-type))) - (mp/with-lock (*style-sheet-cache*/lock) + (bordeaux-threads:with-recursive-lock-held (*style-sheet-cache*/lock) (setf (gethash url *style-sheet-cache*) res)) res))))) diff --git a/src/net/ftp.lisp b/src/net/ftp.lisp index 8a073f6..df160f7 100644 --- a/src/net/ftp.lisp +++ b/src/net/ftp.lisp @@ -683,11 +683,11 @@ ||# (defvar *connection-pool* nil) -(defvar *connection-pool-lock* (mp/make-lock :name "FTP connections pool lock")) +(defvar *connection-pool-lock* (bordeaux-threads:make-lock "FTP connections pool lock")) (defmacro with-ftp-connection-pool (dummy &body body) dummy - `(mp/with-lock (*connection-pool-lock*) + `(bordeaux-threads:with-recursive-lock-held (*connection-pool-lock*) ,@body)) (defun put-ftp-connection-into-pool (connection) diff --git a/src/net/http.lisp b/src/net/http.lisp index 9b1776b..cfb1723 100644 --- a/src/net/http.lisp +++ b/src/net/http.lisp @@ -414,7 +414,7 @@ (cond ((probe-file fn) (with-open-file (stream fn :direction :input) (let ((*package* (symbol-package 'http-cache-entry))) - (let ((res (make-http-cache :lock (mp/make-lock :name "HTTP cache lock") + (let ((res (make-http-cache :lock (bordeaux-threads:make-lock "HTTP cache lock") :directory directory :entries (make-hash-table :test #'equal)))) (setf (http-cache-serial res) (read stream)) @@ -424,13 +424,13 @@ (put-hce res x)) res)))) (t - (make-http-cache :lock (mp/make-lock :name "HTTP cache lock") + (make-http-cache :lock (bordeaux-threads:make-lock "HTTP cache lock") :directory directory :entries (make-hash-table :test #'equal) :serial 0)) ))) (defun commit-cache (&optional (cache (http-cache))) - (mp/with-lock ((http-cache-lock cache)) + (bordeaux-threads:with-recursive-lock-held ((http-cache-lock cache)) (with-open-file (sink (merge-pathnames "index" (http-cache-directory cache)) :direction :output :if-exists :new-version) (let ((*print-pretty* nil) @@ -443,15 +443,15 @@ (http-cache-entries cache)) ))) ) (defun invent-cache-filename (cache) - (mp/with-lock ((http-cache-lock cache)) + (bordeaux-threads:with-recursive-lock-held ((http-cache-lock cache)) (format nil "~5,'0D" (incf (http-cache-serial cache))))) (defun get-hce (cache url) - (mp/with-lock ((http-cache-lock cache)) + (bordeaux-threads:with-recursive-lock-held ((http-cache-lock cache)) (gethash url (http-cache-entries cache)))) (defun put-hce (cache hce) - (mp/with-lock ((http-cache-lock cache)) + (bordeaux-threads:with-recursive-lock-held ((http-cache-lock cache)) ;; if there was already an entry for that URL with under a different filename, ;; delete the old file (let ((old-ce (gethash (hce-url hce) (http-cache-entries cache)))) diff --git a/src/renderer/document.lisp b/src/renderer/document.lisp index 57998c1..519eaea 100644 --- a/src/renderer/document.lisp +++ b/src/renderer/document.lisp @@ -39,8 +39,10 @@ ;; list of all processes working for this document (processes :initform nil :accessor document-processes) - (processes/lock :initform (mp/make-lock :name "doc-proc-list Lock") + (processes/lock :initform (bordeaux-threads:make-lock "doc-proc-list Lock") :accessor document-processes/lock) ;this needs a lock + (processes/cv :initform (bordeaux-threads:make-condition-variable) + :accessor document-processes/cv) (processes-hooks ;; a list of hooks to call when ever the value of processes changes. :initform nil @@ -89,33 +91,44 @@ ;; Runs a process on behalf of a document, `continuation' is the ;; function to be run within the new process. ;; Returns the new process created. - (mp/with-lock ((document-processes/lock document)) + (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document)) (let (new-process) (setf new-process - (mp/process-run-function - name + (bordeaux-threads:make-thread ;; << child (lambda () - (unwind-protect - (funcall continuation) - ;; remove myself from the list of processes - (progn - (mp/with-lock ((document-processes/lock document)) - (setf (document-processes document) - (delete new-process (document-processes document)))) ))) + (catch 'quit-dce-process + (unwind-protect + (funcall continuation) + ;; remove myself from the list of processes + (progn + (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document)) + (setf (document-processes document) + (delete new-process (document-processes document))) + (bordeaux-threads:condition-notify + (document-processes/cv document))))))) ;; >> - )) + :name name)) ;; add new process to list of process (push new-process (document-processes document)) new-process))) +;; bordeaux-threads says that kill-thread might not unwind cleanly. +;; Let's use interrupt-thread then. +(defun kill-dce-thread (thread) + (bordeaux-threads:interrupt-thread + thread + (lambda () (throw 'quit-dce-process nil)))) + (defun kill-all-document-processes (document) (setf (document-dead-p document) t) - (mp/with-lock ((document-processes/lock document)) - (mapc #'mp/process-kill (document-processes document))) - (mp/process-wait "Waiting for documents processes dying." - (lambda () - (null (document-processes document)))) + (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document)) + (mapc #'kill-dce-thread (document-processes document))) + (loop + (bordeaux-threads:with-recursive-lock-held ((document-processes/lock document)) + (unless (document-processes document) + (return)) + (bordeaux-threads:condition-wait (document-processes/cv document)))) (values)) (defstruct image-entry -- 2.11.4.GIT