Skip to content
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
73 lines (67 sloc) 3.08 KB
;;; -*- 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)))
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)
(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
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
(dpb 1 %%scheduler-priority-preemption-field
(promotion-block waiter-queue name
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)
You can’t perform that action at this time.