home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / generalock.l < prev    next >
Encoding:
Text File  |  1991-07-07  |  2.7 KB  |  63 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*-
  2.  
  3. (defflavor xlib::clx-lock () (simple-recursive-normal-lock)
  4.   (:init-keywords :flavor))
  5.  
  6. (defwhopper (lock-internal xlib::clx-lock) (lock-argument)
  7.   (catch 'timeout
  8.     (continue-whopper lock-argument)))
  9.  
  10. (defmethod (lock-block-internal xlib::clx-lock) (lock-argument)
  11.   (declare (dbg:locking-function describe-process-lock-for-debugger self))
  12.   (when (null waiter-queue)
  13.     (setf waiter-queue (make-scheduler-queue :name name))
  14.     (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name)))
  15.   (let ((process (lock-argument-process lock-argument)))
  16.     (unwind-protect
  17.     (progn
  18.       (lock-map-over-conflicting-owners
  19.         self lock-argument
  20.         #'(lambda (other-lock-arg)
  21.         (add-promotion process lock-argument
  22.                    (lock-argument-process other-lock-arg) other-lock-arg)))
  23.       (unless (timer-pending-p timer)
  24.         (when (and (safe-to-use-timers %real-current-process)
  25.                (not dbg:*debugger-might-have-system-problems*))
  26.           (reset-timer-relative-timer-units timer *lock-timer-interval*)))
  27.       (assert (store-conditional (locf latch) process nil))
  28.       (sys:with-aborts-enabled (lock-latch)
  29.         (let ((timeout (lock-argument-getf lock-argument :timeout nil)))
  30.           (cond ((null timeout)
  31.              (promotion-block waiter-queue name #'lock-lockable self lock-argument))
  32.             ((and (plusp timeout)
  33.               (using-resource (timer process-block-timers)
  34.                 ;; Yeah, we know about the internal representation
  35.                 ;; of timers here.
  36.                 (setf (car (timer-args timer)) %real-current-process)
  37.                 (with-scheduler-locked
  38.                   (reset-timer-relative timer timeout)
  39.                   (flet ((lock-lockable-or-timeout (timer lock lock-argument)
  40.                        (or (not (timer-pending-p timer))
  41.                        (lock-lockable lock lock-argument))))
  42.                 (let ((priority (process-process-priority *current-process*)))
  43.                   (if (ldb-test %%scheduler-priority-preemption-field priority)
  44.                       (promotion-block waiter-queue name
  45.                                #'lock-lockable-or-timeout
  46.                                timer self lock-argument)
  47.                       ;; Change to preemptive priority so that when
  48.                       ;; unlock-internal wakes us up so we can have the lock,
  49.                       ;; we will really wake up right away
  50.                       (with-process-priority
  51.                       (dpb 1 %%scheduler-priority-preemption-field
  52.                            priority)
  53.                     (promotion-block waiter-queue name
  54.                                #'lock-lockable-or-timeout
  55.                                timer self lock-argument)))))
  56.                   (lock-lockable self lock-argument)))))
  57.             (t (throw 'timeout nil))))))
  58.       (unless (store-conditional (locf latch) nil process)
  59.     (lock-latch-wait-internal self))
  60.       (remove-promotions process lock-argument))))
  61.  
  62. (compile-flavor-methods xlib::clx-lock)
  63.