Changeset 7689


Ignore:
Timestamp:
Nov 20, 2007, 3:03:32 PM (12 years ago)
Author:
gb
Message:

New locking interface; track lock usage, maintain whostate.

File:
1 edited

Legend:

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

    r7605 r7689  
    1717(in-package "CCL")
    1818
     19
     20(defparameter *locks-held* () "per-thread list of held locks")
     21(defparameter *locks-pending* () "per-thread list of locks we're waiting for.")
     22(defparameter *lock-conses* ())
     23
     24;; Cold-load lossage.
     25(setq *lock-conses* (make-list 20))
     26
     27;;; Per-thread consing, for lock-ownership tracking.
     28(defun %lock-cons (x y)
     29  (let* ((cell (prog1 *lock-conses*
     30                 (setq *lock-conses* (cdr *lock-conses*)))))
     31    (if cell
     32      (progn
     33        (rplaca cell x)
     34        (rplacd cell y))
     35      (cons x y))))
     36
     37
    1938;;; Bootstrapping for futexes
    2039#+(and linuxx8664-target)
     
    3453  (declaim (inline %lock-futex %unlock-futex)))
    3554
    36 ; Miscellany.
     55;;; Miscellany.
    3756
    3857(defun memq (item list)
     
    510529      (yield))))
    511530
     531(eval-when (:compile-toplevel :execute)
     532  (declaim (inline note-lock-wait note-lock-held note-lock-released)))
     533
     534(defun note-lock-wait (lock)
     535  (setq *locks-pending* (%lock-cons lock *locks-pending*)))
     536
     537(defun note-lock-held ()
     538  (let* ((p *locks-pending*))
     539    (setq *locks-pending* (cdr *locks-pending*))
     540    (rplacd p *locks-held*)
     541    (setq *locks-held* p)))
     542
     543(defun note-lock-released ()
     544  (setf (car *locks-held*) nil
     545        *locks-held* (cdr *locks-held*)))
     546
    512547#-futex
    513 (defun %lock-recursive-lock (lock &optional flag)
    514   (with-macptrs ((p)
    515                  (owner (%get-ptr lock target::lockptr.owner))
    516                  (signal (%get-ptr lock target::lockptr.signal))
    517                  (spin (%inc-ptr lock target::lockptr.spinlock)))
    518     (%setf-macptr-to-object p (%current-tcr))
    519     (if (istruct-typep flag 'lock-acquisition)
    520       (setf (lock-acquisition.status flag) nil)
    521       (if flag (report-bad-arg flag 'lock-acquisition)))
    522     (loop
    523       (without-interrupts
    524        (when (eql p owner)
    525          (incf (%get-natural lock target::lockptr.count))
    526          (when flag
    527            (setf (lock-acquisition.status flag) t))
    528          (return t))
    529        (%get-spin-lock spin)
    530        (when (eql 1 (incf (%get-natural lock target::lockptr.avail)))
    531          (setf (%get-ptr lock target::lockptr.owner) p
    532                (%get-natural lock target::lockptr.count) 1)
    533          (setf (%get-natural spin 0) 0)
    534          (if flag
    535            (setf (lock-acquisition.status flag) t))
    536          (return t))
    537        (setf (%get-natural spin 0) 0))
    538       (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock"))))
     548(defun %lock-recursive-lock-object (lock &optional flag)
     549  (let* ((ptr (recursive-lock-ptr lock)))
     550    (with-macptrs ((p)
     551                   (owner (%get-ptr ptr target::lockptr.owner))
     552                   (signal (%get-ptr ptr target::lockptr.signal))
     553                   (spin (%inc-ptr ptr target::lockptr.spinlock)))
     554      (%setf-macptr-to-object p (%current-tcr))
     555      (if (istruct-typep flag 'lock-acquisition)
     556        (setf (lock-acquisition.status flag) nil)
     557        (if flag (report-bad-arg flag 'lock-acquisition)))
     558      (note-lock-wait lock)
     559      (loop
     560        (without-interrupts
     561         (when (eql p owner)
     562           (incf (%get-natural ptr target::lockptr.count))
     563           (note-lock-held)
     564           (when flag
     565             (setf (lock-acquisition.status flag) t))
     566           (return t))
     567         (%get-spin-lock spin)
     568         (when (eql 1 (incf (%get-natural ptr target::lockptr.avail)))
     569           (setf (%get-ptr ptr target::lockptr.owner) p
     570                 (%get-natural ptr target::lockptr.count) 1)
     571           (setf (%get-natural spin 0) 0)
     572           (note-lock-held)
     573           (if flag
     574             (setf (lock-acquisition.status flag) t))
     575           (return t))
     576         (setf (%get-natural spin 0) 0))
     577        (%process-wait-on-semaphore-ptr signal 1 0 (recursive-lock-whostate lock))))))
     578
     579
    539580
    540581#+futex
    541 (defun futex-wait (p val)
    542   (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0))
     582(defun futex-wait (p val whostate)
     583  (with-process-whostate (whostate)
     584    (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0)))
    543585
    544586#+futex
     
    547589
    548590#+futex
    549 (defun %lock-futex (p wait-level)
     591(defun %lock-futex (p wait-level whostate)
    550592  (let* ((val (%ptr-store-conditional p futex-avail futex-locked)))
    551593    (declare (fixnum val))
     
    554596          (if (eql val futex-contended)
    555597            (let* ((*interrupt-level* wait-level))
    556               (futex-wait p val))
     598              (futex-wait p val whostate))
    557599            (setq val futex-contended))
    558600          (when (eql futex-avail (xchgl val p))
     
    566608
    567609
     610
     611
    568612#+futex
    569 (defun %lock-recursive-lock (lock &optional flag)
     613(defun %lock-recursive-lock-object (lock &optional flag)
    570614  (if (istruct-typep flag 'lock-acquisition)
    571615    (setf (lock-acquisition.status flag) nil)
    572616    (if flag (report-bad-arg flag 'lock-acquisition)))
    573617  (let* ((self (%current-tcr))
    574          (level *interrupt-level*))
     618         (level *interrupt-level*)
     619         (ptr (recursive-lock-ptr lock)))
    575620    (declare (fixnum self val))
     621    (note-lock-wait lock)
    576622    (without-interrupts
    577      (cond ((eql self (%get-object lock target::lockptr.owner))
    578             (incf (%get-natural lock target::lockptr.count)))
    579            (t (%lock-futex lock level)
    580               (%set-object lock target::lockptr.owner self)
    581               (setf (%get-natural lock target::lockptr.count) 1)))
     623     (cond ((eql self (%get-object ptr target::lockptr.owner))
     624            (incf (%get-natural ptr target::lockptr.count)))
     625           (t (%lock-futex ptr level (recursive-lock-whostate lock))
     626              (%set-object ptr target::lockptr.owner self)
     627              (setf (%get-natural ptr target::lockptr.count) 1)))
     628     (note-lock-held)
    582629     (when flag
    583630       (setf (lock-acquisition.status flag) t))
     
    586633         
    587634
    588 ;;; Locking the exception lock to inhibit GC (from other threads)
    589 ;;; is probably a bad idea, though it does simplify some issues.
    590 ;;; (One bad consequence is that it means that only one hash table
    591 ;;; can be accessed at a time.)
    592 #+bad-idea
    593 (defun %lock-gc-lock ()
    594   (with-macptrs ((lock))
    595     (%get-kernel-global-ptr exception-lock lock)
    596     (%lock-recursive-lock lock)))
    597 
    598 #+bad-idea
    599 (defun %unlock-gc-lock ()
    600   (with-macptrs ((lock))
    601     (%get-kernel-global-ptr exception-lock lock)
    602     (%unlock-recursive-lock lock)))
     635
     636
    603637
    604638#-futex
    605 (defun %try-recursive-lock (lock &optional flag)
     639(defun %try-recursive-lock-object (lock &optional flag)
    606640  (with-macptrs ((p)
    607                  (owner (%get-ptr lock target::lockptr.owner))
    608                  (spin (%inc-ptr lock target::lockptr.spinlock)))
     641                 (owner (%get-ptr ptr target::lockptr.owner))
     642                 (spin (%inc-ptr ptr target::lockptr.spinlock)))
    609643    (%setf-macptr-to-object p (%current-tcr))
    610644    (if flag
     
    614648    (without-interrupts
    615649     (cond ((eql p owner)
    616             (incf (%get-natural lock target::lockptr.count))
     650            (incf (%get-natural ptr target::lockptr.count))
     651            (setq *locks-held* (%lock-cons lock *locks-held*))
    617652            (if flag (setf (lock-acquisition.status flag) t))
    618653            t)
     
    620655            (let* ((win nil))
    621656              (%get-spin-lock spin)
    622               (when (setq win (eql 1 (incf (%get-natural lock target::lockptr.avail))))
    623                 (setf (%get-ptr lock target::lockptr.owner) p
    624                       (%get-natural lock target::lockptr.count) 1)
     657              (when (setq win (eql 1 (incf (%get-natural ptr target::lockptr.avail))))
     658                (setf (%get-ptr ptr target::lockptr.owner) p
     659                      (%get-natural ptr target::lockptr.count) 1)
     660                (setq *locks-held* (%lock-cons lock *locks-held*))
    625661                (if flag (setf (lock-acquisition.status flag) t)))
    626662              (setf (%get-ptr spin) (%null-ptr))
    627663              win))))))
    628664
     665
     666
    629667#+futex
    630 (defun %try-recursive-lock (lock &optional flag)
    631   (let* ((self (%current-tcr)))
     668(defun %try-recursive-lock-object (lock &optional flag)
     669  (let* ((self (%current-tcr))
     670         (ptr (recursive-lock-ptr lock)))
    632671    (declare (fixnum self))
    633672    (if flag
     
    636675        (report-bad-arg flag 'lock-acquisition)))
    637676    (without-interrupts
    638      (cond ((eql (%get-object lock target::lockptr.owner) self)
    639             (incf (%get-natural lock target::lockptr.count))
     677     (cond ((eql (%get-object ptr target::lockptr.owner) self)
     678            (incf (%get-natural ptr target::lockptr.count))
     679            (setq *locks-held* (%lock-cons lock *locks-held*))
    640680            (if flag (setf (lock-acquisition.status flag) t))
    641681            t)
    642682           (t
    643             (when (eql 0 (%ptr-store-conditional lock futex-avail futex-locked))
    644               (%set-object lock target::lockptr.owner self)
    645               (setf (%get-natural lock target::lockptr.count) 1)
     683            (when (eql 0 (%ptr-store-conditional ptr futex-avail futex-locked))
     684              (%set-object ptr target::lockptr.owner self)
     685              (setf (%get-natural ptr target::lockptr.count) 1)             
     686              (setq *locks-held* (%lock-cons lock *locks-held*))
    646687              (if flag (setf (lock-acquisition.status flag) t))
    647688              t))))))
     
    649690
    650691
     692
     693
    651694#-futex
    652 (defun %unlock-recursive-lock (lock)
    653   (with-macptrs ((signal (%get-ptr lock target::lockptr.signal))
    654                  (spin (%inc-ptr lock target::lockptr.spinlock)))
    655     (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr))
     695(defun %unlock-recursive-lock-object (lock)
     696  (let* ((ptr (%svref lock target::lock._value-cell)))
     697    (with-macptrs ((signal (%get-ptr ptr target::lockptr.signal))
     698                   (spin (%inc-ptr ptr target::lockptr.spinlock)))
     699      (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr))
     700        (error 'not-lock-owner :lock lock))
     701      (without-interrupts
     702       (when (eql 0 (decf (the fixnum
     703                            (%get-natural ptr target::lockptr.count))))
     704         (note-lock-released)
     705         (%get-spin-lock spin)
     706         (setf (%get-ptr ptr target::lockptr.owner) (%null-ptr))
     707         (let* ((pending (+ (the fixnum
     708                              (1- (the fixnum (%get-fixnum ptr target::lockptr.avail))))
     709                            (the fixnum (%get-fixnum ptr target::lockptr.waiting)))))
     710           (declare (fixnum pending))
     711           (setf (%get-natural ptr target::lockptr.avail) 0
     712                 (%get-natural ptr target::lockptr.waiting) 0)
     713           (decf pending)
     714           (if (> pending 0)
     715             (setf (%get-natural ptr target::lockptr.waiting) pending))
     716           (setf (%get-ptr spin) (%null-ptr))
     717           (if (>= pending 0)
     718             (%signal-semaphore-ptr signal)))))))
     719  nil)
     720
     721
     722
     723#+futex
     724(defun %unlock-recursive-lock-object (lock)
     725  (let* ((ptr (%svref lock target::lock._value-cell)))
     726    (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr))
    656727      (error 'not-lock-owner :lock lock))
    657728    (without-interrupts
    658729     (when (eql 0 (decf (the fixnum
    659                           (%get-natural lock target::lockptr.count))))
    660        (%get-spin-lock spin)
    661        (setf (%get-ptr lock target::lockptr.owner) (%null-ptr))
    662        (let* ((pending (+ (the fixnum
    663                             (1- (the fixnum (%get-fixnum lock target::lockptr.avail))))
    664                           (the fixnum (%get-fixnum lock target::lockptr.waiting)))))
    665          (declare (fixnum pending))
    666          (setf (%get-natural lock target::lockptr.avail) 0
    667                (%get-natural lock target::lockptr.waiting) 0)
    668          (decf pending)
    669          (if (> pending 0)
    670            (setf (%get-natural lock target::lockptr.waiting) pending))
    671          (setf (%get-ptr spin) (%null-ptr))
    672          (if (>= pending 0)
    673            (%signal-semaphore-ptr signal))))))
    674     nil)
    675 
    676 #+futex
    677 (defun %unlock-recursive-lock (lock)
    678   (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr))
    679     (error 'not-lock-owner :lock lock))
    680   (without-interrupts
    681    (when (eql 0 (decf (the fixnum
    682                         (%get-natural lock target::lockptr.count))))
    683      (setf (%get-natural lock target::lockptr.owner) 0)
    684      (%unlock-futex lock)))
    685     nil)
     730                          (%get-natural ptr target::lockptr.count))))
     731    (note-lock-released)
     732    (setf (%get-natural ptr target::lockptr.owner) 0)
     733    (%unlock-futex ptr))))
     734  nil)
    686735
    687736
     
    774823;;; signaled before we abandon interest in it
    775824#-futex
    776 (defun %write-lock-rwlock-ptr (ptr &optional flag)
     825(defun %write-lock-rwlock-ptr (ptr lock &optional flag)
    777826  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
    778827    (if (istruct-typep flag 'lock-acquisition)
     
    782831           (tcr (%current-tcr)))
    783832      (declare (fixnum tcr))
     833      (note-lock-wait lock)
    784834      (without-interrupts
    785835       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     
    788838           (incf (%get-signed-natural ptr target::rwlock.state))
    789839           (setf (%get-natural ptr target::rwlock.spin) 0)
     840           (note-lock-held)
    790841           (if flag
    791842             (setf (lock-acquisition.status flag) t))
     
    794845              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
    795846               ;; That wasn't so bad, was it ?  We have the spinlock now.
     847               (note-lock-held)
    796848               (setf (%get-signed-natural ptr target::rwlock.state) 1
    797849                     (%get-natural ptr target::rwlock.spin) 0)
     
    803855           (setf (%get-natural ptr target::rwlock.spin) 0)
    804856           (let* ((*interrupt-level* level))
    805                   (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
     857                  (%process-wait-on-semaphore-ptr write-signal 1 0 (rwlock-write-whostate lock)))
    806858           (%get-spin-lock ptr)))))))
    807859#+futex
    808 (defun %write-lock-rwlock-ptr (ptr &optional flag)
     860(defun %write-lock-rwlock-ptr (ptr lock &optional flag)
    809861  (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) )
    810862    (if (istruct-typep flag 'lock-acquisition)
     
    814866           (tcr (%current-tcr)))
    815867      (declare (fixnum tcr))
     868      (note-lock-wait lock)
    816869      (without-interrupts
    817        (%lock-futex ptr level)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     870       (%lock-futex ptr level "futex wait")               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
    818871       (if (eq (%get-object ptr target::rwlock.writer) tcr)
    819872         (progn
    820873           (incf (%get-signed-natural ptr target::rwlock.state))
    821874           (%unlock-futex ptr)
     875           (note-lock-held)
    822876           (if flag
    823877             (setf (lock-acquisition.status flag) t))
     
    826880              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
    827881               ;; That wasn't so bad, was it ?  We have the spinlock now.
     882               (note-lock-held)
    828883               (setf (%get-signed-natural ptr target::rwlock.state) 1)
    829884               (%unlock-futex ptr)
     
    835890           (let* ((waitval (%get-natural write-signal 0)))
    836891             (%unlock-futex ptr)
    837              (let* ((*interrupt-level* level))
    838                (futex-wait write-signal waitval)))
    839            (%lock-futex ptr level)
     892             (with-process-whostate ((rwlock-write-whostate lock))
     893               (let* ((*interrupt-level* level))
     894                 (futex-wait write-signal waitval (rwlock-write-whostate lock)))))
     895           (%lock-futex ptr level "futex wait")
    840896           (decf (%get-natural ptr target::rwlock.blocked-writers))))))))
    841897
     
    843899
    844900(defun write-lock-rwlock (lock &optional flag)
    845   (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
     901  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
    846902
    847903#-futex
     
    854910           (tcr (%current-tcr)))
    855911      (declare (fixnum tcr))
     912      (note-lock-wait lock)
    856913      (without-interrupts
    857914       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     
    859916         (progn
    860917           (setf (%get-natural ptr target::rwlock.spin) 0)
     918           (setq *locks-pending* (cdr *locks-pending*))
    861919           (error 'deadlock :lock lock))
    862920         (do* ((state
     
    868926                     (the fixnum (1- state))
    869927                     (%get-natural ptr target::rwlock.spin) 0)
     928               (note-lock-held)
    870929               (if flag
    871930                 (setf (lock-acquisition.status flag) t))
     
    875934           (setf (%get-natural ptr target::rwlock.spin) 0)
    876935           (let* ((*interrupt-level* level))
    877              (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
     936             (%process-wait-on-semaphore-ptr read-signal 1 0 (rwlock-read-whostate lock)))
    878937           (%get-spin-lock ptr)))))))
    879938
     
    887946           (tcr (%current-tcr)))
    888947      (declare (fixnum tcr))
     948      (note-lock-wait lock)
    889949      (without-interrupts
    890        (%lock-futex ptr level)
     950       (%lock-futex ptr level "futex wait")
    891951       (if (eq (%get-object ptr target::rwlock.writer) tcr)
    892952         (progn
    893953           (%unlock-futex ptr)
     954           (setq *locks-pending* (cdr *locks-pending*))
    894955           (error 'deadlock :lock lock))
    895956         (do* ((state
     
    900961               (setf (%get-signed-natural ptr target::rwlock.state)
    901962                     (the fixnum (1- state)))
     963               (note-lock-held)
    902964               (%unlock-futex ptr)
    903965               (if flag
     
    909971             (%unlock-futex ptr)
    910972             (let* ((*interrupt-level* level))
    911                (futex-wait reader-signal waitval)))
    912            (%lock-futex ptr level)
     973               (futex-wait reader-signal waitval (rwlock-read-whostate lock))))
     974           (%lock-futex ptr level "futex wait")
    913975           (decf (%get-natural ptr target::rwlock.blocked-readers))))))))
    914976
     
    918980  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
    919981
    920 ;;; If the current thread already owns the lock for writing, increment
    921 ;;; the lock's state.  Otherwise, try to lock the lock for reading.
    922 (defun %ensure-at-least-read-locked (lock &optional flag)
    923   (if (istruct-typep flag 'lock-acquisition)
    924     (setf (lock-acquisition.status flag) nil)
    925     (if flag (report-bad-arg flag 'lock-acquisition)))
    926   (let* ((ptr (read-write-lock-ptr lock))
    927          (tcr (%current-tcr))
    928          #+futex (level *interrupt-level*))
    929     (declare (fixnum tcr))
    930     (or
    931      (without-interrupts
    932       #+futex
    933       (%lock-futex ptr level)
    934       #-futex
    935       (%get-spin-lock ptr)
    936       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
    937         (declare (fixnum state))
    938         (let ((win
    939                (cond ((<= state 0)
    940                       (setf (%get-signed-natural ptr target::rwlock.state)
    941                             (the fixnum (1- state)))
    942                       t)
    943                      ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
    944                       (setf (%get-signed-natural ptr target::rwlock.state)
    945                             (the fixnum (1+ state)))
    946                       t))))
    947           #+futex
    948           (%unlock-futex ptr)
    949           #-futex
    950           (setf (%get-natural ptr target::rwlock.spin) 0)
    951           (when win
    952             (if flag
    953               (setf (lock-acquisition.status flag) t))
    954             t))))
    955        (%read-lock-rwlock-ptr ptr lock flag))))
     982
    956983
    957984#-futex
     
    9941021         ;; are cleared here (they can't be changed from another thread
    9951022         ;; until this thread releases the spinlock.)
     1023         (note-lock-released)
    9961024         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
    9971025         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     
    10161044           (wakeup 0))
    10171045    (without-interrupts
    1018      (%lock-futex ptr -1)
     1046     (%lock-futex ptr -1 "futex wait")
    10191047     (let* ((state (%get-signed-natural ptr target::rwlock.state))
    10201048            (tcr (%current-tcr)))
     
    10301058       (setf (%get-signed-natural ptr target::rwlock.state) state)
    10311059       (when (zerop state)
     1060         (note-lock-released)
    10321061         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
    10331062         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     
    10661095      (without-interrupts
    10671096       #+futex
    1068        (%lock-futex ptr level)
     1097       (%lock-futex ptr level "futex wait")
    10691098       #-futex
    10701099       (%get-spin-lock ptr)
Note: See TracChangeset for help on using the changeset viewer.