diff options
Diffstat (limited to 'third_party/lisp/sclf/mp')
| -rw-r--r-- | third_party/lisp/sclf/mp/README | 6 | ||||
| -rw-r--r-- | third_party/lisp/sclf/mp/cmu.lisp | 115 | ||||
| -rw-r--r-- | third_party/lisp/sclf/mp/sbcl.lisp | 235 |
3 files changed, 0 insertions, 356 deletions
diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README deleted file mode 100644 index a0732c0294..0000000000 --- a/third_party/lisp/sclf/mp/README +++ /dev/null @@ -1,6 +0,0 @@ -This directory contains an uniforming layer for multiprocessing in the -style supported by Allegro Common Lisp and CMUCL. Almost nothing of -this has been written by me. It's mostly the work of Gilbert Baumann -(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM. -The copyright disclaimer in this code is compatible with the one of -SCLF, so I believe there should be no legal issues. diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp deleted file mode 100644 index 1bdbba7989..0000000000 --- a/third_party/lisp/sclf/mp/cmu.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;; -;;; Code freely lifted from various places with compatible license -;;; terms. Most of this code is copyright Gilbert Baumann -;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter -;;; C. Pelissero <walter@pelissero.de>. -;;; - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Library General Public -;;; License as published by the Free Software Foundation; either -;;; version 2 of the License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Library General Public License for more details. -;;; -;;; You should have received a copy of the GNU Library General Public -;;; License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307 USA. - -(in-package :sclf) - -(defun make-lock (&optional name) - (mp:make-lock name)) - -(defun make-recursive-lock (&optional name) - (mp:make-lock name :kind :recursive)) - -(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms) - `(mp:with-lock-held (,lock ,(or whostate "Lock Wait") - :wait wait - ,@(when timeout (list :timeout timeout))) - ,@forms)) - -(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms) - `(mp:with-lock-held (,lock - ,@(when wait (list :wait wait)) - ,@(when timeout (list :timeout timeout))) - ,@forms)) - -(defstruct condition-variable - (lock (make-lock "condition variable")) - (value nil) - (process-queue nil)) - -(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp - #+i486 (kernel:%instance-set-conditional - lock 2 mp:*current-process* nil) - #-i486 (when (eq (lock-process lock) mp:*current-process*) - (setf (lock-process lock) nil))) - -(defun condition-wait (cv lock &optional timeout) - (declare (ignore timeout)) ;For now - (loop - (let ((cv-lock (condition-variable-lock cv))) - (with-lock-held (cv-lock) - (when (condition-variable-value cv) - (setf (condition-variable-value cv) nil) - (return-from condition-wait t)) - (setf (condition-variable-process-queue cv) - (nconc (condition-variable-process-queue cv) - (list mp:*current-process*))) - (%release-lock lock)) - (mp:process-add-arrest-reason mp:*current-process* cv) - (let ((cv-val nil)) - (with-lock-held (cv-lock) - (setq cv-val (condition-variable-value cv)) - (when cv-val - (setf (condition-variable-value cv) nil))) - (when cv-val - (mp::lock-wait lock "waiting for condition variable lock") - (return-from condition-wait t)))))) - -(defun condition-notify (cv) - (with-lock-held ((condition-variable-lock cv)) - (let ((proc (pop (condition-variable-process-queue cv)))) - ;; The waiting process may have released the CV lock but not - ;; suspended itself yet - (when proc - (loop - for activep = (mp:process-active-p proc) - while activep - do (mp:process-yield)) - (setf (condition-variable-value cv) t) - (mp:process-revoke-arrest-reason proc cv)))) - ;; Give the other process a chance - (mp:process-yield)) - -(defun process-execute (process function) - (mp:process-preset process function) - ;; For some obscure reason process-preset doesn't make the process - ;; runnable. I'm sure it's me who didn't understand how - ;; multiprocessing works under CMUCL, despite the vast documentation - ;; available. - (mp:enable-process process) - (mp:process-add-run-reason process :enable)) - -(defun destroy-process (process) - ;; silnetly ignore a process that is trying to destroy itself - (unless (eq (mp:current-process) - process) - (mp:destroy-process process))) - -(defun restart-process (process) - (mp:restart-process process) - (mp:enable-process process) - (mp:process-add-run-reason process :enable)) - -(defun process-alive-p (process) - (mp:process-alive-p process)) - -(defun process-join (process) - (error "PROCESS-JOIN not support under CMUCL.")) diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp deleted file mode 100644 index a2cf497ff9..0000000000 --- a/third_party/lisp/sclf/mp/sbcl.lisp +++ /dev/null @@ -1,235 +0,0 @@ -;;; -;;; Code freely lifted from various places with compatible license -;;; terms. Most of this code is copyright Daniel Barlow -;;; <dan@metacircles.com> or Gilbert Baumann -;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter -;;; C. Pelissero <walter@pelissero.de>. -;;; - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Library General Public -;;; License as published by the Free Software Foundation; either -;;; version 2 of the License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Library General Public License for more details. -;;; -;;; You should have received a copy of the GNU Library General Public -;;; License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307 USA. - -(in-package :sclf) - -(defstruct (process - (:constructor %make-process) - (:predicate processp)) - name - state - whostate - function - thread) - -(defvar *current-process* - (%make-process - :name "initial process" :function nil - :thread - #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - sb-thread:*current-thread* - #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - (sb-thread:current-thread-id))) - -(defvar *all-processes* (list *current-process*)) - -(defvar *all-processes-lock* - (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) - -;; we implement disable-process by making the disablee attempt to lock -;; *permanent-queue*, which is already locked because we locked it -;; here. enable-process just interrupts the lock attempt. - -(defmacro get-mutex (mutex &optional (wait t)) - `( - #+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) - sb-thread:grab-mutex - #-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) - sb-thread:get-mutex - ,mutex :waitp ,wait)) - -(defvar *permanent-queue* - (sb-thread:make-mutex :name "Lock for disabled threads")) -(unless (sb-thread:mutex-owner *permanent-queue*) - (get-mutex *permanent-queue* nil)) - -(defun make-process (function &key name) - (let ((p (%make-process :name name - :function function))) - (sb-thread:with-mutex (*all-processes-lock*) - (pushnew p *all-processes*)) - (restart-process p))) - -(defun process-kill-thread (process) - (let ((thread (process-thread process))) - (when (and thread - (sb-thread:thread-alive-p thread)) - (assert (not (eq thread sb-thread:*current-thread*))) - (sb-thread:terminate-thread thread) - ;; Wait until all the clean-up forms are done. - (sb-thread:join-thread thread :default nil)) - (setf (process-thread process) nil))) - -(defun process-join (process) - (sb-thread:join-thread (process-thread process))) - -(defun restart-process (p) - (labels ((boing () - (let ((*current-process* p) - (function (process-function p))) - (when function - (funcall function))))) - (process-kill-thread p) - (when (setf (process-thread p) - (sb-thread:make-thread #'boing :name (process-name p))) - p))) - -(defun destroy-process (process) - (sb-thread:with-mutex (*all-processes-lock*) - (setf *all-processes* (delete process *all-processes*))) - (process-kill-thread process)) - -(defun current-process () - *current-process*) - -(defun all-processes () - ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value - ;; while that delete is executing, we could end up with nonsense. - ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). - (sb-thread:with-mutex (*all-processes-lock*) - *all-processes*)) - -(defun process-yield () - (sb-thread:thread-yield)) - -(defun process-wait (reason predicate) - (let ((old-state (process-whostate *current-process*))) - (unwind-protect - (progn - (setf old-state (process-whostate *current-process*) - (process-whostate *current-process*) reason) - (until (funcall predicate) - (process-yield))) - (setf (process-whostate *current-process*) old-state)))) - -(defun process-wait-with-timeout (reason timeout predicate) - (let ((old-state (process-whostate *current-process*)) - (end-time (+ (get-universal-time) timeout))) - (unwind-protect - (progn - (setf old-state (process-whostate *current-process*) - (process-whostate *current-process*) reason) - (loop - for result = (funcall predicate) - until (or result - (> (get-universal-time) end-time)) - do (process-yield) - finally (return result))) - (setf (process-whostate *current-process*) old-state)))) - -(defun process-interrupt (process function) - (sb-thread:interrupt-thread (process-thread process) function)) - -(defun disable-process (process) - (sb-thread:interrupt-thread - (process-thread process) - (lambda () - (catch 'interrupted-wait (get-mutex *permanent-queue*))))) - -(defun enable-process (process) - (sb-thread:interrupt-thread - (process-thread process) (lambda () (throw 'interrupted-wait nil)))) - -(defmacro without-scheduling (&body body) - (declare (ignore body)) - (error "WITHOUT-SCHEDULING is not supported on this platform.")) - -(defparameter *atomic-lock* - (sb-thread:make-mutex :name "atomic incf/decf")) - -(defmacro atomic-incf (place) - `(sb-thread:with-mutex (*atomic-lock*) - (incf ,place))) - -(defmacro atomic-decf (place) - `(sb-thread:with-mutex (*atomic-lock*) - (decf ,place))) - -;;; 32.3 Locks - -(defun make-lock (&optional name) - (sb-thread:make-mutex :name name)) - -(defmacro with-lock-held ((place &key state (wait t) timeout) &body body) - (declare (ignore timeout)) - (let ((old-state (gensym "OLD-STATE"))) - `(sb-thread:with-mutex (,place :wait-p ,wait) - (let (,old-state) - (unwind-protect - (progn - (when ,state - (setf ,old-state (process-state *current-process*)) - (setf (process-state *current-process*) ,state)) - ,@body) - (setf (process-state *current-process*) ,old-state)))))) - - -(defun make-recursive-lock (&optional name) - (sb-thread:make-mutex :name name)) - -(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body) - (declare (ignore wait timeout)) - (let ((old-state (gensym "OLD-STATE"))) - `(sb-thread:with-recursive-lock (,place) - (let (,old-state) - (unwind-protect - (progn - (when ,state - (setf ,old-state (process-state *current-process*)) - (setf (process-state *current-process*) ,state)) - ,@body) - (setf (process-state *current-process*) ,old-state)))))) - -(defun make-condition-variable () (sb-thread:make-waitqueue)) - -(defun condition-wait (cv lock &optional timeout) - (if timeout - (handler-case - (sb-ext:with-timeout timeout - (sb-thread:condition-wait cv lock) - t) - (sb-ext:timeout (c) - (declare (ignore c)) - nil)) - (progn (sb-thread:condition-wait cv lock) t))) - -(defun condition-notify (cv) - (sb-thread:condition-notify cv)) - - -(defvar *process-plists* (make-hash-table) - "Hash table mapping processes to a property list. This is used by -PROCESS-PLIST.") - -(defun process-property-list (process) - (gethash process *process-plists*)) - -(defun (setf process-property-list) (value process) - (setf (gethash process *process-plists*) value)) - -(defun process-execute (process function) - (setf (process-function process) function) - (restart-process process)) - -(defun process-alive-p (process) - (sb-thread:thread-alive-p (process-thread process))) |