Changeset 7394


Ignore:
Timestamp:
Oct 12, 2007, 9:26:46 AM (12 years ago)
Author:
gb
Message:

frozen-dnodes changes for ROOM et al, new rwlock stuff.

File:
1 edited

Legend:

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

    r6917 r7394  
    129129  t)
    130130
    131 
     131(defun frozen-space-dnodes ()
     132  "Returns the current size of the frozen area."
     133  (%fixnum-ref-natural (%get-kernel-global 'tenured-area)
     134                       target::area.static-dnodes))
    132135(defun %usedbytes ()
    133136  (%normalize-areas)
     
    147150                (incf library bytes)
    148151                (incf static bytes))))))
    149       (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))
    150         (decf dynamic hons-size)
    151         (values dynamic static library hons-size))))
     152      (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift)))
     153        (decf dynamic frozen-size)
     154        (values dynamic static library frozen-size))))
    152155
    153156
     
    199202
    200203
    201 ; Returns six values.
    202 ;   sp free
    203 ;   sp used
    204 ;   vsp free
    205 ;   vsp used
    206 ;   tsp free
    207 ;   tsp used
     204;;; Returns six values.
     205;;;   sp free
     206;;;   sp used
     207;;;   vsp free
     208;;;   vsp used
     209;;;   tsp free
     210;;;   tsp used
    208211(defun %thread-stack-space (&optional (thread *current-lisp-thread*))
    209212  (when (eq thread *current-lisp-thread*)
     
    267270         (static-used nil)
    268271         (staticlib-used nil)
    269          (hons-space-size nil)
     272         (frozen-space-size nil)
    270273         (lispheap nil)
    271274         (reserved nil)
     
    275278         (stack-free)
    276279         (stack-used-by-thread nil))
    277     (with-other-threads-suspended
    278         (without-gcing
    279          (setq freebytes (%freebytes))
    280          (when verbose
    281            (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
    282              (%usedbytes))
    283            (setq lispheap (+ freebytes usedbytes)
    284                  reserved (%reservedbytes)
    285                  static (+ static-used staticlib-used hons-space-size))
    286            (multiple-value-setq (stack-total stack-used stack-free)
    287              (%stack-space))
    288            (unless (eq verbose :default)
    289              (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
     280    (progn
     281      (progn
     282        (setq freebytes (%freebytes))
     283        (when verbose
     284          (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size)
     285            (%usedbytes))
     286          (setq lispheap (+ freebytes usedbytes)
     287                reserved (%reservedbytes)
     288                static (+ static-used staticlib-used frozen-space-size))
     289          (multiple-value-setq (stack-total stack-used stack-free)
     290            (%stack-space))
     291          (unless (eq verbose :default)
     292            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
    290293    (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
    291294    (when verbose
     
    305308                0 0
    306309                static (k static))
    307         (when (and hons-space-size (not (zerop hons-space-size)))
    308           (format t "~&~,3f MB of static memory reserved for hash consing."
    309                   (/ hons-space-size (float (ash 1 20)))))
     310        (when (and frozen-space-size (not (zerop frozen-space-size)))
     311          (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory"
     312                  (/ frozen-space-size (float (ash 1 20)))))
    310313        (format t "~&~,3f MB reserved for heap expansion."
    311314                (/ reserved (float (ash 1 20))))
     
    388391       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
    389392        (%str-from-ptr pointer end))
     393    (declare (fixnum end))))
     394
     395(defun %get-utf-8-cstring (pointer)
     396  (do* ((end 0 (1+ end)))
     397       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
     398        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
     399               (string (make-string len)))
     400          (utf-8-memory-decode pointer end 0 string)
     401          string))
    390402    (declare (fixnum end))))
    391403
     
    640652(defun %atomic-incf-symbol-value (s &optional (by 1))
    641653  (setq s (require-type s 'symbol))
    642   (let* ((binding-address (%symbol-binding-address s)))
    643     (declare (fixnum binding-address))
    644     (if (zerop binding-address)
    645       (%atomic-incf-node by s target::symbol.vcell-cell)
    646       (%atomic-incf-node by binding-address (* 2 target::node-size)))))
    647 
    648 (defun write-lock-rwlock (lock)
    649   (let* ((context (%current-tcr)))
    650     (if (eq (%svref lock target::lock.writer-cell) context)
    651       (progn
    652         (decf (%svref lock target::lock._value-cell))
    653         lock)
    654       (loop
    655         (when (%store-immediate-conditional target::lock._value lock 0 -1)
    656           (setf (%svref lock target::lock.writer-cell) context)
    657           (return lock))
    658         (%nanosleep 0 *ns-per-tick*)))))
    659 
    660 
    661 (defun read-lock-rwlock (lock)
    662   (loop
    663     (when (%try-read-lock-rwlock lock)
    664       (return lock))
    665     (%nanosleep 0 *ns-per-tick*)))
     654  (multiple-value-bind (base offset) (%symbol-binding-address s)
     655    (%atomic-incf-node by base offset)))
     656
     657;;; What happens if there are some pending readers and another writer,
     658;;; and we abort out of the semaphore wait ?  If the writer semaphore is
     659;;; signaled before we abandon interest in it
     660(defun %write-lock-rwlock-ptr (ptr &optional flag)
     661  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
     662    (if (istruct-typep flag 'lock-acquisition)
     663      (setf (lock-acquisition.status flag) nil)
     664      (if flag (report-bad-arg flag 'lock-acquisition)))
     665    (let* ((level *interrupt-level*)
     666           (tcr (%current-tcr)))
     667      (declare (fixnum tcr))
     668      (without-interrupts
     669       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     670       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     671         (progn
     672           (incf (%get-signed-natural ptr target::rwlock.state))
     673           (setf (%get-natural ptr target::rwlock.spin) 0)
     674           (if flag
     675             (setf (lock-acquisition.status flag) t))
     676           t)
     677         (do* ()
     678              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
     679               ;; That wasn't so bad, was it ?  We have the spinlock now.
     680               (setf (%get-signed-natural ptr target::rwlock.state) 1
     681                     (%get-natural ptr target::rwlock.spin) 0)
     682               (%set-object ptr target::rwlock.writer tcr)
     683               (if flag
     684                 (setf (lock-acquisition.status flag) t))
     685               t)
     686           (incf (%get-natural ptr target::rwlock.blocked-writers))
     687           (setf (%get-natural ptr target::rwlock.spin) 0)
     688           (let* ((*interrupt-level* level))
     689                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
     690           (%get-spin-lock ptr)))))))
     691
     692(defun write-lock-rwlock (lock &optional flag)
     693  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
     694
     695(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
     696  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
     697    (if (istruct-typep flag 'lock-acquisition)
     698      (setf (lock-acquisition.status flag) nil)
     699      (if flag (report-bad-arg flag 'lock-acquisition)))
     700    (let* ((level *interrupt-level*)
     701           (tcr (%current-tcr)))
     702      (declare (fixnum tcr))
     703      (without-interrupts
     704       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     705       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     706         (progn
     707           (setf (%get-natural ptr target::rwlock.spin) 0)
     708           (error 'deadlock :lock lock))
     709         (do* ((state
     710                (%get-signed-natural ptr target::rwlock.state)
     711                (%get-signed-natural ptr target::rwlock.state)))
     712              ((<= state 0)
     713               ;; That wasn't so bad, was it ?  We have the spinlock now.
     714               (setf (%get-signed-natural ptr target::rwlock.state)
     715                     (the fixnum (1- state))
     716                     (%get-natural ptr target::rwlock.spin) 0)
     717               (if flag
     718                 (setf (lock-acquisition.status flag) t))
     719               t)
     720           (declare (fixnum state))
     721           (incf (%get-natural ptr target::rwlock.blocked-readers))
     722           (setf (%get-natural ptr target::rwlock.spin) 0)
     723           (let* ((*interrupt-level* level))
     724             (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
     725           (%get-spin-lock ptr)))))))
     726
     727(defun read-lock-rwlock (lock &optional flag)
     728  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
     729
     730;;; If the current thread already owns the lock for writing, increment
     731;;; the lock's state.  Otherwise, try to lock the lock for reading.
     732(defun %ensure-at-least-read-locked (lock &optional flag)
     733  (if (istruct-typep flag 'lock-acquisition)
     734    (setf (lock-acquisition.status flag) nil)
     735    (if flag (report-bad-arg flag 'lock-acquisition)))
     736  (let* ((ptr (read-write-lock-ptr lock))
     737         (tcr (%current-tcr)))
     738    (declare (fixnum tcr))
     739    (or
     740     (without-interrupts
     741      (%get-spin-lock ptr)
     742      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     743        (declare (fixnum state))
     744        (let ((win
     745               (cond ((<= state 0)
     746                      (setf (%get-signed-natural ptr target::rwlock.state)
     747                            (the fixnum (1- state)))
     748                      t)
     749                     ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
     750                      (setf (%get-signed-natural ptr target::rwlock.state)
     751                            (the fixnum (1+ state)))
     752                      t))))
     753          (setf (%get-natural ptr target::rwlock.spin) 0)
     754          (when win
     755            (if flag
     756              (setf (lock-acquisition.status flag) t))
     757            t))))
     758       (%read-lock-rwlock-ptr ptr lock flag))))
     759
     760(defun %unlock-rwlock-ptr (ptr lock)
     761  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
     762                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
     763    (without-interrupts
     764     (%get-spin-lock ptr)
     765     (let* ((state (%get-signed-natural ptr target::rwlock.state))
     766            (tcr (%current-tcr)))
     767       (declare (fixnum state tcr))
     768       (cond ((> state 0)
     769              (unless (eql tcr (%get-object ptr target::rwlock.writer))
     770                (setf (%get-natural ptr target::rwlock.spin) 0)
     771                (error 'not-lock-owner :lock lock))
     772              (decf state))
     773             ((< state 0) (incf state))
     774             (t (setf (%get-natural ptr target::rwlock.spin) 0)
     775                (error 'not-locked :lock lock)))
     776       (setf (%get-signed-natural ptr target::rwlock.state) state)
     777       (when (zerop state)
     778         ;; We want any thread waiting for a lock semaphore to
     779         ;; be able to wait interruptibly.  When a thread waits,
     780         ;; it increments either the "blocked-readers" or "blocked-writers"
     781         ;; field, but since it may get interrupted before obtaining
     782         ;; the semaphore that's more of "an expression of interest"
     783         ;; in taking the lock than it is "a firm commitment to take it."
     784         ;; It's generally (much) better to signal the semaphore(s)
     785         ;; too often than it would be to not signal them often
     786         ;; enough; spurious wakeups are better than deadlock.
     787         ;; So: if there are blocked writers, the writer-signal
     788         ;; is raised once for each apparent blocked writer.  (At most
     789         ;; one writer will actually succeed in taking the lock.)
     790         ;; If there are blocked readers, the reader-signal is raised
     791         ;; once for each of them.  (It's possible for both the
     792         ;; reader and writer semaphores to be raised on the same
     793         ;; unlock; the writer semaphore is raised first, so in that
     794         ;; sense, writers still have priority but it's not guaranteed.)
     795         ;; Both the "blocked-writers" and "blocked-readers" fields
     796         ;; are cleared here (they can't be changed from another thread
     797         ;; until this thread releases the spinlock.)
     798         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
     799         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     800                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
     801           (declare (fixnum nreaders nwriters))
     802           (when (> nwriters 0)
     803             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
     804             (dotimes (i nwriters)
     805               (%signal-semaphore-ptr writer-signal)))
     806           (when (> nreaders 0)
     807             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
     808             (dotimes (i nreaders)
     809               (%signal-semaphore-ptr reader-signal)))))
     810       (setf (%get-natural ptr target::rwlock.spin) 0)
     811       t))))
     812
     813(defun unlock-rwlock (lock)
     814  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
     815
     816;;; There are all kinds of ways to lose here.
     817;;; The caller must have read access to the lock exactly once,
     818;;; or have write access.
     819;;; there's currently no way to detect whether the caller has
     820;;; read access at all.
     821;;; If we have to block and get interrupted, cleanup code may
     822;;; try to unlock a lock that we don't hold. (It might be possible
     823;;; to circumvent that if we use the same notifcation object here
     824;;; that controls that cleanup process.)
     825
     826(defun %promote-rwlock (lock &optional flag)
     827  (let* ((ptr (read-write-lock-ptr lock)))
     828    (if (istruct-typep flag 'lock-acquisition)
     829      (setf (lock-acquisition.status flag) nil)
     830      (if flag (report-bad-arg flag 'lock-acquisition)))
     831    (let* ((level *interrupt-level*)
     832           (tcr (%current-tcr)))
     833      (without-interrupts
     834       (%get-spin-lock ptr)
     835       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     836         (declare (fixnum state))
     837         (cond ((> state 0)
     838                (unless (eql (%get-object ptr target::rwlock.writer) tcr)
     839                  (setf (%get-natural ptr target::rwlock.spin) 0)
     840                  (error :not-lock-owner :lock lock)))
     841               ((= state 0)
     842                  (setf (%get-natural ptr target::rwlock.spin) 0)
     843                  (error :not-locked :lock lock))
     844               (t
     845                (if (= state -1)
     846                  (progn
     847                    (setf (%get-signed-natural ptr target::rwlock.state) 1
     848                          (%get-natural ptr target::rwlock.spin) 0)
     849                    (%set-object ptr target::rwlock.writer tcr)
     850                    (if flag
     851                      (setf (lock-acquisition.status flag) t))
     852                    t)
     853                  (progn
     854                    (%unlock-rwlock-ptr ptr lock)
     855                    (let* ((*interrupt-level* level))
     856                      (%write-lock-rwlock-ptr ptr flag)))))))))))
     857                     
     858               
     859           
     860           
     861 
     862
    666863
    667864(defun safe-get-ptr (p &optional dest)
Note: See TracChangeset for help on using the changeset viewer.