Changeset 7196


Ignore:
Timestamp:
Sep 11, 2007, 11:23:39 AM (12 years ago)
Author:
gb
Message:

New READ-WRITE-LOCK stuff.

File:
1 edited

Legend:

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

    r7025 r7196  
    199199
    200200
    201 ; Returns six values.
    202 ;   sp free
    203 ;   sp used
    204 ;   vsp free
    205 ;   vsp used
    206 ;   tsp free
    207 ;   tsp used
     201;;; Returns six values.
     202;;;   sp free
     203;;;   sp used
     204;;;   vsp free
     205;;;   vsp used
     206;;;   tsp free
     207;;;   tsp used
    208208(defun %thread-stack-space (&optional (thread *current-lisp-thread*))
    209209  (when (eq thread *current-lisp-thread*)
     
    649649(defun %atomic-incf-symbol-value (s &optional (by 1))
    650650  (setq s (require-type s 'symbol))
    651   (let* ((binding-address (%symbol-binding-address s)))
    652     (declare (fixnum binding-address))
    653     (if (zerop binding-address)
    654       (%atomic-incf-node by s target::symbol.vcell-cell)
    655       (%atomic-incf-node by binding-address (* 2 target::node-size)))))
    656 
    657 (defun write-lock-rwlock (lock)
    658   (let* ((context (%current-tcr)))
    659     (if (eq (%svref lock target::lock.writer-cell) context)
    660       (progn
    661         (decf (%svref lock target::lock._value-cell))
    662         lock)
    663       (loop
    664         (when (%store-immediate-conditional target::lock._value lock 0 -1)
    665           (setf (%svref lock target::lock.writer-cell) context)
    666           (return lock))
    667         (%nanosleep 0 *ns-per-tick*)))))
    668 
    669 
    670 (defun read-lock-rwlock (lock)
    671   (loop
    672     (when (%try-read-lock-rwlock lock)
    673       (return lock))
    674     (%nanosleep 0 *ns-per-tick*)))
     651  (multiple-value-bind (base offset) (%symbol-binding-address s)
     652    (%atomic-incf-node by base offset)))
     653
     654;;; What happens if there are some pending readers and another writer,
     655;;; and we abort out of the semaphore wait ?  If the writer semaphore is
     656;;; 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))
     661    (if (istruct-typep flag 'lock-acquisition)
     662      (setf (lock-acquisition.status flag) nil)
     663      (if flag (report-bad-arg flag 'lock-acquisition)))
     664    (let* ((level *interrupt-level*))
     665      (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)
     668         (progn
     669           (incf (%get-signed-natural lock target::rwlock.state))
     670           (setf (%get-natural lock target::rwlock.spin) 0)
     671           (if flag
     672             (setf (lock-acquisition.status flag) t))
     673           t)
     674         (do* ()
     675              ((eql 0 (%get-signed-natural lock target::rwlock.state))
     676               ;; 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)
     680               (if flag
     681                 (setf (lock-acquisition.status flag) t))
     682               t)
     683           (incf (%get-natural lock target::rwlock.blocked-writers))
     684           (setf (%get-natural lock target::rwlock.spin) 0)
     685           (let* ((*interrupt-level* level))
     686                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
     687           (%get-spin-lock lock)))))))
     688
     689(defun write-lock-rwlock (lock &optional flag)
     690  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
     691
     692(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))
     696    (if (istruct-typep flag 'lock-acquisition)
     697      (setf (lock-acquisition.status flag) nil)
     698      (if flag (report-bad-arg flag 'lock-acquisition)))
     699    (let* ((level *interrupt-level*))
     700      (without-interrupts
     701       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     702       (if (%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
     703         (progn
     704           (setf (%get-natural ptr target::rwlock.spin) 0)
     705           (error 'deadlock :lock lock))
     706         (do* ((state
     707                (%get-signed-natural ptr target::rwlock.state)
     708                (%get-signed-natural ptr target::rwlock.state)))
     709              ((<= state 0)
     710               ;; That wasn't so bad, was it ?  We have the spinlock now.
     711               (setf (%get-signed-natural ptr target::rwlock.state)
     712                     (the fixnum (1- state))
     713                     (%get-natural ptr target::rwlock.spin) 0)
     714               (if flag
     715                 (setf (lock-acquisition.status flag) t))
     716               t)
     717           (declare (fixnum state))
     718           (incf (%get-natural ptr target::rwlock.blocked-readers))
     719           (setf (%get-natural ptr target::rwlock.spin) 0)
     720           (let* ((*interrupt-level* level))
     721             (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
     722           (%get-spin-lock ptr)))))))
     723
     724(defun read-lock-rwlock (lock &optional flag)
     725  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
     726
     727
     728(defun %unlock-rwlock-ptr (ptr lock)
     729  (with-macptrs (tcr
     730                 (reader-signal (%get-ptr ptr target::rwlock.reader-signal))
     731                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
     732    (%setf-macptr-to-object tcr (%current-tcr))
     733    (without-interrupts
     734     (%get-spin-lock ptr)
     735     (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     736       (declare (fixnum state))
     737       (cond ((> state 0)
     738              (unless (%ptr-eql tcr (%get-ptr ptr target::rwlock.writer))
     739                (format t "~& state = ~s" state)
     740                (setf (%get-natural ptr target::rwlock.spin) 0)
     741                (error 'not-lock :lock lock))
     742              (decf state))
     743             ((< state 0) (incf state))
     744             (t (setf (%get-natural ptr target::rwlock.spin) 0)
     745                (error 'not-lock-owner :lock lock)))
     746       (setf (%get-signed-natural ptr target::rwlock.state) state)
     747       (when (zerop state)
     748         ;; We want any thread waiting for a lock semaphore to
     749         ;; be able to wait interruptibly.  When a thread waits,
     750         ;; it increments either the "blocked-readers" or "blocked-writers"
     751         ;; field, but since it may get interrupted before obtaining
     752         ;; the semaphore that's more of "an expression of interest"
     753         ;; in taking the lock than it is "a firm commitment to take it."
     754         ;; It's generally (much) better to signal the semaphore(s)
     755         ;; too often than it would be to not signal them often
     756         ;; enough; spurious wakeups are better than deadlock.
     757         ;; So: if there are blocked writers, the writer-signal
     758         ;; is raised once for each apparent blocked writer.  (At most
     759         ;; one writer will actually succeed in taking the lock.)
     760         ;; If there are blocked readers, the reader-signal is raised
     761         ;; once for each of them.  (It's possible for both the
     762         ;; reader and writer semaphores to be raised on the same
     763         ;; unlock; the writer semaphore is raised first, so in that
     764         ;; sense, writers still have priority but it's not guaranteed.)
     765         ;; Both the "blocked-writers" and "blocked-readers" fields
     766         ;; are cleared here (they can't be changed from another thread
     767         ;; until this thread releases the spinlock.)
     768         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
     769         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     770                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
     771           (declare (fixnum nreaders nwriters))
     772           (when (> nwriters 0)
     773             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
     774             (dotimes (i nwriters)
     775               (%signal-semaphore-ptr writer-signal)))
     776           (when (> nreaders 0)
     777             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
     778             (dotimes (i nreaders)
     779               (%signal-semaphore-ptr reader-signal)))))
     780       (setf (%get-natural ptr target::rwlock.spin) 0)
     781       t))))
     782
     783(defun unlock-rwlock (lock)
     784  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
     785
    675786
    676787(defun safe-get-ptr (p &optional dest)
Note: See TracChangeset for help on using the changeset viewer.