(in-package :clim-sys-internals) (defvar *pid* (sb-thread::current-thread-id)) (defvar *konses* nil) (defstruct (process (:constructor %make-process) (:predicate processp)) name state whostate function id) (defvar *current-process* (%make-process :name "initial process" :function nil)) (defun make-process (function &key (name "anonymous")) (let ((p (%make-process :name name))) (setf (process-id p) (sb-thread:make-thread (lambda () (let ((*current-process* p) (*pid* (sb-thread::current-thread-id)) (*konses* nil)) (funcall function))))) p)) (defun current-process () *current-process*) #-CLIM-SYS-INTERNAL::USE-WAITQUEUE (progn ;;;; Spin Locks (defstruct spin-lock (spin 0)) ; 0 means free, otherwise the pid is entered (declaim (inline current-thread-id)) (defun current-thread-id () *pid*) (defun acquire-spin-lock (spin-lock) (declare (optimize (speed 3) (safety 0))) (loop until (eql (sb-vm::%instance-set-conditional spin-lock #|offset|# 1 #|old value|# 0 #|new value|# (current-thread-id)) 0) do (sleep 0) )) (defun release-spin-lock (spin-lock) (declare (type spin-lock spin-lock)) (setf (spin-lock-spin spin-lock) 0)) (defmacro with-spin-lock ((lock-form) &body body) (let ((lock (gensym ".LOCK."))) `(let ((,lock ,lock-form)) (unwind-protect (progn (acquire-spin-lock ,lock) (locally ,@body)) (release-spin-lock ,lock))))) ;;;; Waiting and Wakeup ;; We provide two alternative implementations #+CLIM-SYS-INTERNALS::USE-PIPES (progn (defvar *thread-pipes* (make-hash-table :test #'eq)) (defvar *thread-pipes-spin* (make-spin-lock)) (defun thread-pipe (pid) (with-spin-lock (*thread-pipes-spin*) (or (gethash pid *thread-pipes*) (setf (gethash pid *thread-pipes*) (make-thread-pipe))))) (defun make-thread-pipe () (multiple-value-list (sb-unix:unix-pipe))) (defvar *scratch-buf* (SB-SYS:ALLOCATE-SYSTEM-MEMORY 1)) (defun prepare-wait () ) (defun wait () (sb-unix:unix-read (first (thread-pipe (current-thread-id))) *scratch-buf* 1)) (defun wakeup (pid) (sb-unix:unix-write (second (thread-pipe pid)) *scratch-buf* 0 1)) ) #-CLIM-SYS-INTERNALS::USE-PIPES (progn (defun prepare-wait () (sb-thread::block-sigcont)) (defun wait () (sb-thread::unblock-sigcont-and-sleep)) (defun wakeup (pid) (sb-unix:unix-kill pid :sigcont)) ) ;;;; Regular Locks ;; Note: Our locks are always recursive. (defstruct (queue (:include spin-lock)) (queue nil)) (declaim (inline queue-push queue-pop)) (defun kons (x y) (let ((r (pop *konses*))) (if r (progn (setf (car r) x (cdr r) y) r) (cons x y)))) (defun snok (cell) (push cell *konses*)) #+NIL (progn (defun queue-push (queue) (declare (type queue queue)) (let ((p (current-thread-id)) (q (queue-queue queue))) (cond ((null q) (setf (queue-queue queue) p)) ((atom q) (setf (queue-queue queue) (cons p (cons q nil)))) (t (setf (queue-queue queue) (cons p q)))))) (defun queue-pop (queue) (declare (type queue queue)) (let ((p (queue-queue queue))) (cond ((atom p) (setf (queue-queue queue) nil) p) (t (setf (queue-queue queue) (cdr (queue-queue queue))) (car p))))) ) #-NIL (progn (defun queue-push (queue) (declare (type queue queue)) (push (current-thread-id) (queue-queue queue))) (defun queue-pop (queue) (declare (type queue queue)) (pop (queue-queue queue)))) #+NIL (progn (defun queue-push (queue) (declare (type queue queue)) (setf (queue-queue queue) (kons (current-thread-id) (queue-queue queue)))) (defun queue-pop (queue) (declare (type queue queue)) (let ((x (queue-queue queue))) (if (consp x) (progn (snok x) (setf (queue-queue queue) (cdr x)) (car x)) nil)))) ;;; (defstruct (lock (:include queue)) name (lock-count 0) ;how many times this was acquired (holder nil)) (defun acquire-lock (lock) (loop (acquire-spin-lock lock) (cond ((null (lock-holder lock)) ;; this one is free, just acquire it. (incf (lock-lock-count lock)) (setf (lock-holder lock) (current-thread-id)) (release-spin-lock lock) (return)) ((eql (lock-holder lock) (current-thread-id)) (incf (lock-lock-count lock)) (release-spin-lock lock) (return)) (t ;; Holded by somebody else, just put us on the queue (prepare-wait) (queue-push lock) (release-spin-lock lock) (wait))))) (defun release-lock (lock) (acquire-spin-lock lock) (decf (lock-lock-count lock)) (when (zerop (lock-lock-count lock)) (setf (lock-holder lock) nil) ;it's free now (let ((p (queue-pop lock))) (release-spin-lock lock) ;<-- hope this is safe ... (when p ;; somebody is waiting (wakeup p)))) #+NIL(release-spin-lock lock)) (defmacro with-lock-held ((lock-form) &body body) (let ((lock (gensym ".LOCK."))) `(let ((,lock ,lock-form)) (unwind-protect (progn (acquire-lock ,lock) (locally ,@body)) (release-lock ,lock))))) (defmacro with-recursive-lock-held ((lock-form) &body body) `(with-lock-held (,lock-form) ,@body)) (defun make-recursive-lock (&key name) (make-lock :name name)) ;;;; condition variables (defstruct (condition-variable (:include queue)) ) (defun condition-notify (cv) (let ((p (queue-pop cv))) (cond ((null p) (warn "~S without somebody waiting, Eh?" 'CONDITION-NOTIFY)) (t (wakeup p))))) (defun condition-wait (cv lock) (queue-push cv) (prepare-wait) (release-lock lock) (wait) (acquire-lock lock)) ) ;;;;; #+CLIM-SYS-INTERNALS::USE-WAITQUEUE (progn (defun make-lock (&optional name) (sb-thread:make-mutex :name name)) (defmacro with-lock-held ((place &optional state) &body body) (let ((old-state (gensym "OLD-STATE"))) `(let (,old-state) (unwind-protect (progn (sb-thread:get-mutex ,place) (when ,state (setf ,old-state (process-state *current-process*)) (setf (process-state *current-process*) ,state)) ,@body) (setf (process-state *current-process*) ,old-state) (sb-thread::release-mutex ,place))))) (defun make-recursive-lock (&optional name) (sb-thread:make-mutex :name name)) (defmacro with-recursive-lock-held ((place &optional state) &body body) (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 (condition-variable lock) (sb-thread:condition-wait condition-variable lock)) (defun condition-notify (condition-variable) (sb-thread:condition-notify condition-variable)))