/usr/share/common-lisp/source/clx/generalock.lisp is in cl-clx-sbcl 0.7.4.20160323-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | ;;; -*- 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)
|