Changeset 10503

Show
Ignore:
Timestamp:
08/20/08 10:37:19 (3 months ago)
Author:
gz
Message:

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

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • 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