mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-30 04:10:44 -08:00
72 lines
3.1 KiB
Common Lisp
72 lines
3.1 KiB
Common 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)
|