Changeset 10503


Ignore:
Timestamp:
Aug 20, 2008, 2:37:19 PM (11 years ago)
Author:
gz
Message:

More careful locking/tcr handling in symbol-value-in-process, process-whostate.
(Merge r10453/r10454/r10459/r10460/r10461 from trunk)

Location:
branches/working-0711/ccl
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/l0-aprims.lisp

    r10391 r10503  
    133133  (make-lock nil))
    134134
     135(defun %make-lock (pointer name)
     136  (gvector :lock pointer 'recursive-lock 0 name nil nil))
     137
    135138(defun make-lock (&optional name)
    136139  "Create and return a lock object, which can be used for synchronization
    137140between threads."
    138   (gvector :lock (%make-recursive-lock-ptr) 'recursive-lock 0 name nil nil))
     141  (%make-lock (%make-recursive-lock-ptr) name))
    139142
    140143(defun lock-name (lock)
  • branches/working-0711/ccl/level-0/l0-misc.lisp

    r9942 r10503  
    2222(defparameter *lock-conses* ())
    2323
    24 ;; Cold-load lossage.
    25 #+lock-accounting
    26 (setq *lock-conses* (make-list 20))
    27 
    28 ;;; Per-thread consing, for lock-ownership tracking.
    29 #+lock-accounting
    30 (defun %lock-cons (x y)
    31   (let* ((cell (prog1 *lock-conses*
    32                  (setq *lock-conses* (cdr *lock-conses*)))))
    33     (if cell
    34       (progn
    35         (rplaca cell x)
    36         (rplacd cell y))
    37       (cons x y))))
     24
    3825
    3926
     
    529516  (declaim (inline note-lock-wait note-lock-held note-lock-released)))
    530517
    531 (defun note-lock-wait (lock)
    532   #+lock-accounting
    533   (setq *locks-pending* (%lock-cons lock *locks-pending*))
    534   #-lock-accounting (declare (ignore lock)))
    535 
    536 (defun note-lock-held ()
    537   #+lock-accounting
    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   #+lock-accounting
    545   (setf (car *locks-held*) nil
    546         *locks-held* (cdr *locks-held*)))
     518
     519
     520
    547521
    548522#-futex
     
    557531        (setf (lock-acquisition.status flag) nil)
    558532        (if flag (report-bad-arg flag 'lock-acquisition)))
    559       (note-lock-wait lock)
    560533      (loop
    561534        (without-interrupts
    562535         (when (eql p owner)
    563536           (incf (%get-natural ptr target::lockptr.count))
    564            (note-lock-held)
    565537           (when flag
    566538             (setf (lock-acquisition.status flag) t))
     
    571543                 (%get-natural ptr target::lockptr.count) 1)
    572544           (setf (%get-natural spin 0) 0)
    573            (note-lock-held)
    574545           (if flag
    575546             (setf (lock-acquisition.status flag) t))
     
    635606         (ptr (recursive-lock-ptr lock)))
    636607    (declare (fixnum self))
    637     (note-lock-wait lock)
    638608    (without-interrupts
    639609     (cond ((eql self (%get-object ptr target::lockptr.owner))
     
    642612              (%set-object ptr target::lockptr.owner self)
    643613              (setf (%get-natural ptr target::lockptr.count) 1)))
    644      (note-lock-held)
    645614     (when flag
    646615       (setf (lock-acquisition.status flag) t))
     
    723692       (when (eql 0 (decf (the fixnum
    724693                            (%get-natural ptr target::lockptr.count))))
    725          (note-lock-released)
    726694         (%get-spin-lock spin)
    727695         (setf (%get-ptr ptr target::lockptr.owner) (%null-ptr))
     
    750718     (when (eql 0 (decf (the fixnum
    751719                          (%get-natural ptr target::lockptr.count))))
    752     (note-lock-released)
    753720    (setf (%get-natural ptr target::lockptr.owner) 0)
    754721    (%unlock-futex ptr))))
     
    838805           (tcr (%current-tcr)))
    839806      (declare (fixnum tcr))
    840       (note-lock-wait lock)
    841807      (without-interrupts
    842808       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     
    845811           (incf (%get-signed-natural ptr target::rwlock.state))
    846812           (setf (%get-natural ptr target::rwlock.spin) 0)
    847            (note-lock-held)
    848813           (if flag
    849814             (setf (lock-acquisition.status flag) t))
     
    852817              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
    853818               ;; That wasn't so bad, was it ?  We have the spinlock now.
    854                (note-lock-held)
    855819               (setf (%get-signed-natural ptr target::rwlock.state) 1
    856820                     (%get-natural ptr target::rwlock.spin) 0)
     
    873837           (tcr (%current-tcr)))
    874838      (declare (fixnum tcr))
    875       (note-lock-wait lock)
    876839      (without-interrupts
    877840       (%lock-futex ptr level lock nil)
     
    880843           (incf (%get-signed-natural ptr target::rwlock.state))
    881844           (%unlock-futex ptr)
    882            (note-lock-held)
    883845           (if flag
    884846             (setf (lock-acquisition.status flag) t))
     
    887849              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
    888850               ;; That wasn't so bad, was it ?  We have the spinlock now.
    889                (note-lock-held)
    890851               (setf (%get-signed-natural ptr target::rwlock.state) 1)
    891852               (%unlock-futex ptr)
     
    917878           (tcr (%current-tcr)))
    918879      (declare (fixnum tcr))
    919       (note-lock-wait lock)
    920880      (without-interrupts
    921881       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     
    933893                     (the fixnum (1- state))
    934894                     (%get-natural ptr target::rwlock.spin) 0)
    935                (note-lock-held)
    936895               (if flag
    937896                 (setf (lock-acquisition.status flag) t))
     
    953912           (tcr (%current-tcr)))
    954913      (declare (fixnum tcr))
    955       (note-lock-wait lock)
    956914      (without-interrupts
    957915       (%lock-futex ptr level lock nil)
     
    968926               (setf (%get-signed-natural ptr target::rwlock.state)
    969927                     (the fixnum (1- state)))
    970                (note-lock-held)
    971928               (%unlock-futex ptr)
    972929               (if flag
     
    1028985         ;; are cleared here (they can't be changed from another thread
    1029986         ;; until this thread releases the spinlock.)
    1030          (note-lock-released)
    1031987         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
    1032988         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     
    10651021       (setf (%get-signed-natural ptr target::rwlock.state) state)
    10661022       (when (zerop state)
    1067          (note-lock-released)
    10681023         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
    10691024         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r9943 r10503  
    4040    (record-source-file symbol 'variable)
    4141    symbol))
     42
     43(defstatic *kernel-tcr-area-lock* (%make-lock (%null-ptr) "Kernel tcr-area-lock"))
     44
     45(defstatic *kernel-exception-lock* (%make-lock (%null-ptr) "Kernel exception-lock"))
     46 
     47(def-ccl-pointers kernel-locks ()
     48  (let* ((p (recursive-lock-ptr *kernel-tcr-area-lock*))
     49         (q (recursive-lock-ptr *kernel-exception-lock*)))
     50    (%revive-macptr p)
     51    (%revive-macptr q)
     52    (%get-kernel-global-ptr area-lock p)
     53    (%get-kernel-global-ptr exception-lock q)))
    4254
    4355(def-standard-initial-binding *package*)
  • branches/working-0711/ccl/level-1/l1-lisp-threads.lisp

    r9947 r10503  
    3535
    3636(defun %nanosleep (seconds nanoseconds)
    37   (rlet ((a :timespec)
    38          (b :timespec))
    39     (setf (pref a :timespec.tv_sec) seconds
    40           (pref a :timespec.tv_nsec) nanoseconds)
    41     (let* ((aptr a)
    42            (bptr b))
    43       (loop
    44         (let* ((result
    45                 (external-call #+darwin-target "_nanosleep"
    46                                #-darwin-target "nanosleep"
    47                                :address aptr
    48                                :address bptr
    49                                :signed-fullword)))
    50           (declare (type (signed-byte 32) result))
    51           (if (and (< result 0)
    52                    (eql (%get-errno) (- #$EINTR)))
    53             ;; x86-64 Leopard bug.
    54             (let* ((asec (pref aptr :timespec.tv_sec))
    55                    (bsec (pref bptr :timespec.tv_sec)))
    56               (if (and (>= bsec 0)
    57                        (or (< bsec asec)
    58                            (and (= bsec asec)
    59                                 (< (pref bptr :timespec.tv_nsec)
    60                                    (pref aptr :timespec.tv_nsec)))))
    61                 (psetq aptr bptr bptr aptr)
    62                 (return)))
    63             (return)))))))
     37  (with-process-whostate ("Sleep")
     38    (rlet ((a :timespec)
     39           (b :timespec))
     40      (setf (pref a :timespec.tv_sec) seconds
     41            (pref a :timespec.tv_nsec) nanoseconds)
     42      (let* ((aptr a)
     43             (bptr b))
     44        (loop
     45          (let* ((result
     46                  (external-call #+darwin-target "_nanosleep"
     47                                 #-darwin-target "nanosleep"
     48                                 :address aptr
     49                                 :address bptr
     50                                 :signed-fullword)))
     51            (declare (type (signed-byte 32) result))
     52            (if (and (< result 0)
     53                     (eql (%get-errno) (- #$EINTR)))
     54              ;; x86-64 Leopard bug.
     55              (let* ((asec (pref aptr :timespec.tv_sec))
     56                     (bsec (pref bptr :timespec.tv_sec)))
     57                (if (and (>= bsec 0)
     58                         (or (< bsec asec)
     59                             (and (= bsec asec)
     60                                  (< (pref bptr :timespec.tv_nsec)
     61                                     (pref aptr :timespec.tv_nsec)))))
     62                  (psetq aptr bptr bptr aptr)
     63                  (return)))
     64              (return))))))))
    6465
    6566
     
    315316  (%fixnum-ref tcr target::tcr.flags))
    316317
    317 (defun tcr-exhausted-p (tcr)
    318   (or (null tcr)
    319       (eql tcr 0)
    320       (unless (logbitp arch::tcr-flag-bit-awaiting-preset
    321                        (the fixnum (tcr-flags tcr)))
    322         (let* ((vs-area (%fixnum-ref tcr target::tcr.vs-area)))
    323           (declare (fixnum vs-area))
    324           (or (zerop vs-area)
    325               (eq (%fixnum-ref vs-area target::area.high)
    326                   (%fixnum-ref tcr target::tcr.save-vsp)))))))
     318
    327319
    328320(defun thread-exhausted-p (thread)
    329321  (or (null thread)
    330       (tcr-exhausted-p (lisp-thread.tcr thread))))
     322      (null (lisp-thread.tcr thread))))
    331323
    332324(defun thread-total-run-time (thread)
  • branches/working-0711/ccl/level-1/l1-processes.lisp

    r10393 r10503  
    211211        (thread-exhausted-p thread))))
    212212 
    213 
     213;;; This should be way more concerned about being correct and thread-safe
     214;;; than about being quick: it's generally only called while printing
     215;;; or debugging, and there are all kinds of subtle race conditions
     216;;; here.
    214217(defun process-whostate (p)
    215218  "Return a string which describes the status of a specified process."
    216   (if (process-exhausted-p p)
    217     "Exhausted"
    218     (symbol-value-in-process '*whostate* p)))
     219    (let* ((ip *initial-process*))
     220      (cond ((eq p *current-process*)
     221             (if (%tcr-binding-location (%current-tcr) '*whostate*)
     222               *whostate*
     223               (if (eq p ip)
     224                 "Active"
     225                 "Reset")))
     226            (t
     227             (without-interrupts
     228              (with-lock-grabbed (*kernel-exception-lock*)
     229               (with-lock-grabbed (*kernel-tcr-area-lock*)
     230                 (let* ((tcr (process-tcr p)))
     231                   (if tcr
     232                     (unwind-protect
     233                          (let* ((loc nil))
     234                            (%suspend-tcr tcr)
     235                            (setq loc (%tcr-binding-location tcr '*whostate*))
     236                            (if loc
     237                              (%fixnum-ref loc)
     238                              (if (eq p ip)
     239                                "Active"
     240                                "Reset")))
     241                       (%resume-tcr tcr))
     242                     "Exhausted")))))))))
    219243
    220244(defun (setf process-whostate) (new p)
     
    243267  (if (eq process *current-process*)
    244268    (symbol-value sym)
    245     (symbol-value-in-tcr sym (process-tcr process))))
     269    (let* ((val
     270            (without-interrupts
     271             (with-lock-grabbed (*kernel-exception-lock*)
     272               (with-lock-grabbed (*kernel-tcr-area-lock*)
     273                 (let* ((tcr (process-tcr process)))
     274                   (if tcr
     275                     (symbol-value-in-tcr sym tcr)
     276                     (%sym-global-value sym))))))))
     277      (if (eq val (%unbound-marker))
     278        ;; This might want to be a CELL-ERROR.
     279        (error "~S is unbound in ~S." sym process)
     280        val))))
    246281
    247282(defun (setf symbol-value-in-process) (value sym process)
    248283  (if (eq process *current-process*)
    249284    (setf (symbol-value sym) value)
    250     (setf (symbol-value-in-tcr sym (process-tcr process)) value)))
     285    (with-lock-grabbed (*kernel-exception-lock*)
     286      (with-lock-grabbed (*kernel-tcr-area-lock*)
     287        (let* ((tcr (process-tcr process)))
     288          (if tcr
     289            (setf (symbol-value-in-tcr sym tcr) value)
     290            (%set-sym-global-value sym value)))))))
    251291
    252292
Note: See TracChangeset for help on using the changeset viewer.