Changeset 7261


Ignore:
Timestamp:
Sep 19, 2007, 9:53:06 AM (12 years ago)
Author:
gb
Message:

New rwlock primitives.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0709/ccl/level-0/l0-misc.lisp

    r7196 r7261  
    655655;;; and we abort out of the semaphore wait ?  If the writer semaphore is
    656656;;; signaled before we abandon interest in it
    657 (defun %write-lock-rwlock-ptr (lock &optional flag)
    658   (with-macptrs (tcr
    659                  (write-signal (%get-ptr lock target::rwlock.writer-signal)))
    660     (%setf-macptr-to-object tcr (%current-tcr))
     657(defun %write-lock-rwlock-ptr (ptr &optional flag)
     658  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
    661659    (if (istruct-typep flag 'lock-acquisition)
    662660      (setf (lock-acquisition.status flag) nil)
    663661      (if flag (report-bad-arg flag 'lock-acquisition)))
    664     (let* ((level *interrupt-level*))
     662    (let* ((level *interrupt-level*)
     663           (tcr (%current-tcr)))
     664      (declare (fixnum tcr))
    665665      (without-interrupts
    666        (%get-spin-lock lock)               ;(%get-spin-lock (%inc-ptr lock target::rwlock.spin))
    667        (if (%ptr-eql (%get-ptr lock target::rwlock.writer) tcr)
     666       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     667       (if (eq (%get-object ptr target::rwlock.writer) tcr)
    668668         (progn
    669            (incf (%get-signed-natural lock target::rwlock.state))
    670            (setf (%get-natural lock target::rwlock.spin) 0)
     669           (incf (%get-signed-natural ptr target::rwlock.state))
     670           (setf (%get-natural ptr target::rwlock.spin) 0)
    671671           (if flag
    672672             (setf (lock-acquisition.status flag) t))
    673673           t)
    674674         (do* ()
    675               ((eql 0 (%get-signed-natural lock target::rwlock.state))
     675              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
    676676               ;; That wasn't so bad, was it ?  We have the spinlock now.
    677                (setf (%get-signed-natural lock target::rwlock.state) 1
    678                      (%get-ptr lock target::rwlock.writer) tcr
    679                      (%get-natural lock target::rwlock.spin) 0)
     677               (setf (%get-signed-natural ptr target::rwlock.state) 1
     678                     (%get-natural ptr target::rwlock.spin) 0)
     679               (%set-object ptr target::rwlock.writer tcr)
    680680               (if flag
    681681                 (setf (lock-acquisition.status flag) t))
    682682               t)
    683            (incf (%get-natural lock target::rwlock.blocked-writers))
    684            (setf (%get-natural lock target::rwlock.spin) 0)
     683           (incf (%get-natural ptr target::rwlock.blocked-writers))
     684           (setf (%get-natural ptr target::rwlock.spin) 0)
    685685           (let* ((*interrupt-level* level))
    686686                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
    687            (%get-spin-lock lock)))))))
     687           (%get-spin-lock ptr)))))))
    688688
    689689(defun write-lock-rwlock (lock &optional flag)
     
    691691
    692692(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
    693   (with-macptrs (tcr
    694                  (read-signal (%get-ptr ptr target::rwlock.reader-signal)))
    695     (%setf-macptr-to-object tcr (%current-tcr))
     693  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
    696694    (if (istruct-typep flag 'lock-acquisition)
    697695      (setf (lock-acquisition.status flag) nil)
    698696      (if flag (report-bad-arg flag 'lock-acquisition)))
    699     (let* ((level *interrupt-level*))
     697    (let* ((level *interrupt-level*)
     698           (tcr (%current-tcr)))
     699      (declare (fixnum tcr))
    700700      (without-interrupts
    701701       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
    702        (if (%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
     702       (if (eq (%get-object ptr target::rwlock.writer) tcr)
    703703         (progn
    704704           (setf (%get-natural ptr target::rwlock.spin) 0)
     
    725725  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
    726726
     727;;; If the current thread already owns the lock for writing, increment
     728;;; the lock's state.  Otherwise, try to lock the lock for reading.
     729(defun %ensure-at-least-read-locked (lock &optional flag)
     730  (if (istruct-typep flag 'lock-acquisition)
     731    (setf (lock-acquisition.status flag) nil)
     732    (if flag (report-bad-arg flag 'lock-acquisition)))
     733  (let* ((ptr (read-write-lock-ptr lock))
     734         (tcr (%current-tcr)))
     735    (declare (fixnum tcr))
     736    (or
     737     (without-interrupts
     738      (%get-spin-lock ptr)
     739      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     740        (declare (fixnum state))
     741        (let ((win
     742               (cond ((<= state 0)
     743                      (setf (%get-signed-natural ptr target::rwlock.state)
     744                            (the fixnum (1- state)))
     745                      t)
     746                     ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
     747                      (setf (%get-signed-natural ptr target::rwlock.state)
     748                            (the fixnum (1+ state)))
     749                      t))))
     750          (setf (%get-natural ptr target::rwlock.spin) 0)
     751          (when win
     752            (if flag
     753              (setf (lock-acquisition.status flag) t))
     754            t))))
     755       (%read-lock-rwlock-ptr ptr lock flag))))
    727756
    728757(defun %unlock-rwlock-ptr (ptr lock)
    729   (with-macptrs (tcr
    730                  (reader-signal (%get-ptr ptr target::rwlock.reader-signal))
     758  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
    731759                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
    732     (%setf-macptr-to-object tcr (%current-tcr))
    733760    (without-interrupts
    734761     (%get-spin-lock ptr)
    735      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
    736        (declare (fixnum state))
     762     (let* ((state (%get-signed-natural ptr target::rwlock.state))
     763            (tcr (%current-tcr)))
     764       (declare (fixnum state tcr))
    737765       (cond ((> state 0)
    738               (unless (%ptr-eql tcr (%get-ptr ptr target::rwlock.writer))
    739                 (format t "~& state = ~s" state)
     766              (unless (eql tcr (%get-object ptr target::rwlock.writer))
    740767                (setf (%get-natural ptr target::rwlock.spin) 0)
    741                 (error 'not-lock :lock lock))
     768                (error 'not-lock-owner :lock lock))
    742769              (decf state))
    743770             ((< state 0) (incf state))
    744771             (t (setf (%get-natural ptr target::rwlock.spin) 0)
    745                 (error 'not-lock-owner :lock lock)))
     772                (error 'not-locked :lock lock)))
    746773       (setf (%get-signed-natural ptr target::rwlock.state) state)
    747774       (when (zerop state)
     
    784811  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
    785812
     813;;; There are all kinds of ways to lose here.
     814;;; The caller must have read access to the lock exactly once,
     815;;; or have write access.
     816;;; there's currently no way to detect whether the caller has
     817;;; read access at all.
     818;;; If we have to block and get interrupted, cleanup code may
     819;;; try to unlock a lock that we don't hold. (It might be possible
     820;;; to circumvent that if we use the same notifcation object here
     821;;; that controls that cleanup process.)
     822
     823(defun %promote-rwlock (lock &optional flag)
     824  (let* ((ptr (read-write-lock-ptr lock)))
     825    (if (istruct-typep flag 'lock-acquisition)
     826      (setf (lock-acquisition.status flag) nil)
     827      (if flag (report-bad-arg flag 'lock-acquisition)))
     828    (let* ((level *interrupt-level*)
     829           (tcr (%current-tcr)))
     830      (without-interrupts
     831       (%get-spin-lock ptr)
     832       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     833         (declare (fixnum state))
     834         (cond ((> state 0)
     835                (unless (eql (%get-object ptr target::tcr.writer) tcr)
     836                  (setf (%get-natural ptr target::rwlock.spin) 0)
     837                  (error :not-lock-owner :lock lock)))
     838               ((= state 0)
     839                  (setf (%get-natural ptr target::rwlock.spin) 0)
     840                  (error :not-locked :lock lock))
     841               (t
     842                (if (= state -1)
     843                  (progn
     844                    (setf (%get-signed-natural ptr target::rwlock.state) 1
     845                          (%get-natural ptr target::rwlock.spin) 0)
     846                    (%set-object ptr target::rwlock.writer tcr)
     847                    (if flag
     848                      (setf (lock-acquisition.status flag) t))
     849                    t)
     850                  (progn
     851                    (%unlock-rwlock-ptr ptr lock)
     852                    (let* ((*interrupt-level* level))
     853                      (%write-lock-rwlock-ptr ptr flag)))))))))))
     854                     
     855               
     856           
     857           
     858 
     859
    786860
    787861(defun safe-get-ptr (p &optional dest)
Note: See TracChangeset for help on using the changeset viewer.