maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(3p/lisp): import sclf source tarball

Browse source 
Used http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz (sha256
a231aeecdb9e87c72642292a1e083fffb33e69ec1d34e667326c6c35b8bcc794).
There's no upstream repository nor a release since 2015, so importing
seems to make a lot of sense.

Since we can't subtree making any depot-related changes in a separate CL
to make them more discoverable -- this is only the source import.

Change-Id: Ia51a7f4029dba3abd1eee4eeebcf99aca5c5ba4c
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3376
Tested-by: BuildkiteCI
Reviewed-by: grfn <grfn@gws.fyi>
This commit is contained in:
sterni 2021-08-21 14:58:48 +02:00
parent 70e5783e22
commit a5dbd0f5d9
12 changed files with 3599 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

6
third_party/lisp/sclf/mp/README vendored Normal file
View file

@ -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.

115
third_party/lisp/sclf/mp/cmu.lisp vendored Normal file
View file

@ -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."))

235
third_party/lisp/sclf/mp/sbcl.lisp vendored Normal file
View file

@ -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)))