generalock.lisp

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*-

;;; Copyright (C) 1990 Symbolics, Inc.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Symbolics, Inc. provides this software "as is" without
;;; express or implied warranty.

(defflavor xlib::clx-lock () (simple-recursive-normal-lock)
  (:init-keywords :flavor))

(defwhopper (lock-internal xlib::clx-lock) (lock-argument)
  (catch 'timeout
    (continue-whopper lock-argument)))

(defmethod (lock-block-internal xlib::clx-lock) (lock-argument)
  (declare (dbg:locking-function describe-process-lock-for-debugger self))
  (when (null waiter-queue)
    (setf waiter-queue (make-scheduler-queue :name name))
    (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name)))
  (let ((process (lock-argument-process lock-argument)))
    (unwind-protect
	(progn
	  (lock-map-over-conflicting-owners
	    self lock-argument
	    #'(lambda (other-lock-arg)
		(add-promotion process lock-argument
			       (lock-argument-process other-lock-arg) other-lock-arg)))
	  (unless (timer-pending-p timer)
	    (when (and (safe-to-use-timers %real-current-process)
		       (not dbg:*debugger-might-have-system-problems*))
	      (reset-timer-relative-timer-units timer *lock-timer-interval*)))
	  (assert (store-conditional (locf latch) process nil))
	  (sys:with-aborts-enabled (lock-latch)
	    (let ((timeout (lock-argument-getf lock-argument :timeout nil)))
	      (cond ((null timeout)
		     (promotion-block waiter-queue name #'lock-lockable self lock-argument))
		    ((and (plusp timeout)
			  (using-resource (timer process-block-timers)
			    ;; Yeah, we know about the internal representation
			    ;; of timers here.
			    (setf (car (timer-args timer)) %real-current-process)
			    (with-scheduler-locked
			      (reset-timer-relative timer timeout)
			      (flet ((lock-lockable-or-timeout (timer lock lock-argument)
				       (or (not (timer-pending-p timer))
					   (lock-lockable lock lock-argument))))
				(let ((priority (process-process-priority *current-process*)))
				  (if (ldb-test %%scheduler-priority-preemption-field priority)
				      (promotion-block waiter-queue name
						       #'lock-lockable-or-timeout
						       timer self lock-argument)
				      ;; Change to preemptive priority so that when
				      ;; unlock-internal wakes us up so we can have the lock,
				      ;; we will really wake up right away
				      (with-process-priority
					  (dpb 1 %%scheduler-priority-preemption-field
					       priority)
					(promotion-block waiter-queue name
						       #'lock-lockable-or-timeout
						       timer self lock-argument)))))
			      (lock-lockable self lock-argument)))))
		    (t (throw 'timeout nil))))))
      (unless (store-conditional (locf latch) nil process)
	(lock-latch-wait-internal self))
      (remove-promotions process lock-argument))))

(compile-flavor-methods xlib::clx-lock)