about summary refs log tree commit diff
path: root/third_party/lisp/sclf/mp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/sclf/mp')
-rw-r--r--third_party/lisp/sclf/mp/README6
-rw-r--r--third_party/lisp/sclf/mp/cmu.lisp115
-rw-r--r--third_party/lisp/sclf/mp/sbcl.lisp235
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 0000000000..a0732c0294
--- /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 0000000000..1bdbba7989
--- /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 0000000000..a2cf497ff9
--- /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)))