Changeset 7394 for branches/working-0710/ccl/level-0/l0-misc.lisp
- Timestamp:
- Oct 12, 2007, 9:26:46 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0710/ccl/level-0/l0-misc.lisp
r6917 r7394 129 129 t) 130 130 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)) 132 135 (defun %usedbytes () 133 136 (%normalize-areas) … … 147 150 (incf library bytes) 148 151 (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)))) 152 155 153 156 … … 199 202 200 203 201 ; Returns six values.202 ; sp free203 ; sp used204 ; vsp free205 ; vsp used206 ; tsp free207 ; tsp used204 ;;; Returns six values. 205 ;;; sp free 206 ;;; sp used 207 ;;; vsp free 208 ;;; vsp used 209 ;;; tsp free 210 ;;; tsp used 208 211 (defun %thread-stack-space (&optional (thread *current-lisp-thread*)) 209 212 (when (eq thread *current-lisp-thread*) … … 267 270 (static-used nil) 268 271 (staticlib-used nil) 269 ( hons-space-size nil)272 (frozen-space-size nil) 270 273 (lispheap nil) 271 274 (reserved nil) … … 275 278 (stack-free) 276 279 (stack-used-by-thread nil)) 277 ( with-other-threads-suspended278 (without-gcing279 280 281 (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)282 283 284 285 static (+ static-used staticlib-used hons-space-size))286 287 288 289 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)))))) 290 293 (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) 291 294 (when verbose … … 305 308 0 0 306 309 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))))) 310 313 (format t "~&~,3f MB reserved for heap expansion." 311 314 (/ reserved (float (ash 1 20)))) … … 388 391 ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) 389 392 (%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)) 390 402 (declare (fixnum end)))) 391 403 … … 640 652 (defun %atomic-incf-symbol-value (s &optional (by 1)) 641 653 (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 666 863 667 864 (defun safe-get-ptr (p &optional dest)
Note: See TracChangeset
for help on using the changeset viewer.