Changeset 10460


Ignore:
Timestamp:
Aug 13, 2008, 11:39:42 AM (11 years ago)
Author:
gb
Message:

%NANOSLEEP binds *WHOSTATE*.
Lose %TCR-EXHAUSTED-P: a tcr is a moving target. If a thread has
a tcr at the time we look, it's not "exhausted"; otherwise, it is.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-lisp-threads.lisp

    r10210 r10460  
    3636
    3737(defun %nanosleep (seconds nanoseconds)
    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)))))))
     38  (with-process-whostate ("Sleep")
     39    (rlet ((a :timespec)
     40           (b :timespec))
     41      (setf (pref a :timespec.tv_sec) seconds
     42            (pref a :timespec.tv_nsec) nanoseconds)
     43      (let* ((aptr a)
     44             (bptr b))
     45        (loop
     46          (let* ((result
     47                  (external-call #+darwin-target "_nanosleep"
     48                                 #-darwin-target "nanosleep"
     49                                 :address aptr
     50                                 :address bptr
     51                                 :signed-fullword)))
     52            (declare (type (signed-byte 32) result))
     53            (if (and (< result 0)
     54                     (eql (%get-errno) (- #$EINTR)))
     55              ;; x86-64 Leopard bug.
     56              (let* ((asec (pref aptr :timespec.tv_sec))
     57                     (bsec (pref bptr :timespec.tv_sec)))
     58                (if (and (>= bsec 0)
     59                         (or (< bsec asec)
     60                             (and (= bsec asec)
     61                                  (< (pref bptr :timespec.tv_nsec)
     62                                     (pref aptr :timespec.tv_nsec)))))
     63                  (psetq aptr bptr bptr aptr)
     64                  (return)))
     65              (return))))))))
    6566
    6667
     
    321322  (%fixnum-ref tcr target::tcr.flags))
    322323
    323 (defun tcr-exhausted-p (tcr)
    324   (or (null tcr)
    325       (eql tcr 0)
    326       (unless (logbitp arch::tcr-flag-bit-awaiting-preset
    327                        (the fixnum (tcr-flags tcr)))
    328         (let* ((vs-area (%fixnum-ref tcr target::tcr.vs-area)))
    329           (declare (fixnum vs-area))
    330           (or (zerop vs-area)
    331               (eq (%fixnum-ref vs-area target::area.high)
    332                   (%fixnum-ref tcr target::tcr.save-vsp)))))))
     324
    333325
    334326(defun thread-exhausted-p (thread)
    335327  (or (null thread)
    336       (tcr-exhausted-p (lisp-thread.tcr thread))))
     328      (null (lisp-thread.tcr thread))))
    337329
    338330(defun thread-total-run-time (thread)
Note: See TracChangeset for help on using the changeset viewer.