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, 356 insertions, 0 deletions
diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README new file mode 100644 index 000000000000..a0732c029453 --- /dev/null +++ b/third_party/lisp/sclf/mp/README @@ -0,0 +1,6 @@ +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 new file mode 100644 index 000000000000..1bdbba79896f --- /dev/null +++ b/third_party/lisp/sclf/mp/cmu.lisp @@ -0,0 +1,115 @@ +;;; +;;; 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 new file mode 100644 index 000000000000..a2cf497ff9bf --- /dev/null +++ b/third_party/lisp/sclf/mp/sbcl.lisp @@ -0,0 +1,235 @@ +;;; +;;; 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))) |