Changeset 7394 for branches/working-0710/ccl/level-0/l0-misc.lisp

Timestamp:

Oct 12, 2007, 9:26:46 AM (13 years ago)

Author:

gb

Message:

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

File:

• branches/working-0710/ccl/level-0/l0-misc.lisp (modified) (8 diffs)

branches/working-0710/ccl/level-0/l0-misc.lisp

@@ -129 +129 @@
   t)
 
-
+(defun frozen-space-dnodes ()
+  "Returns the current size of the frozen area."
+  (%fixnum-ref-natural (%get-kernel-global 'tenured-area)
+                       target::area.static-dnodes))
 (defun %usedbytes ()
   (%normalize-areas)
@@ -147 +150 @@
                 (incf library bytes)
                 (incf static bytes))))))
-      (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))
-        (decf dynamic hons-size)
-        (values dynamic static library hons-size))))
+      (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift)))
+        (decf dynamic frozen-size)
+        (values dynamic static library frozen-size))))
 
 
@@ -199 +202 @@
 
 
-; Returns six values.
-;   sp free
-;   sp used
-;   vsp free
-;   vsp used
-;   tsp free
-;   tsp used
+;;; Returns six values.
+;;;   sp free
+;;;   sp used
+;;;   vsp free
+;;;   vsp used
+;;;   tsp free
+;;;   tsp used
 (defun %thread-stack-space (&optional (thread *current-lisp-thread*))
   (when (eq thread *current-lisp-thread*)
@@ -267 +270 @@
          (static-used nil)
          (staticlib-used nil)
-         (hons-space-size nil)
+         (frozen-space-size nil)
          (lispheap nil)
          (reserved nil)
@@ -275 +278 @@
          (stack-free)
          (stack-used-by-thread nil))
-    (with-other-threads-suspended
-        (without-gcing
-         (setq freebytes (%freebytes))
-         (when verbose
-           (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
-             (%usedbytes))
-           (setq lispheap (+ freebytes usedbytes)
-                 reserved (%reservedbytes)
-                 static (+ static-used staticlib-used hons-space-size))
-           (multiple-value-setq (stack-total stack-used stack-free)
-             (%stack-space))
-           (unless (eq verbose :default)
-             (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
+    (progn
+      (progn
+        (setq freebytes (%freebytes))
+        (when verbose
+          (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size)
+            (%usedbytes))
+          (setq lispheap (+ freebytes usedbytes)
+                reserved (%reservedbytes)
+                static (+ static-used staticlib-used frozen-space-size))
+          (multiple-value-setq (stack-total stack-used stack-free)
+            (%stack-space))
+          (unless (eq verbose :default)
+            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
     (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
     (when verbose
@@ -305 +308 @@
                 0 0
                 static (k static))
-        (when (and hons-space-size (not (zerop hons-space-size)))
-          (format t "~&~,3f MB of static memory reserved for hash consing."
-                  (/ hons-space-size (float (ash 1 20)))))
+        (when (and frozen-space-size (not (zerop frozen-space-size)))
+          (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory"
+                  (/ frozen-space-size (float (ash 1 20)))))
         (format t "~&~,3f MB reserved for heap expansion."
                 (/ reserved (float (ash 1 20))))
@@ -388 +391 @@
        ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
         (%str-from-ptr pointer end))
+    (declare (fixnum end))))
+
+(defun %get-utf-8-cstring (pointer)
+  (do* ((end 0 (1+ end)))
+       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
+        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
+               (string (make-string len)))
+          (utf-8-memory-decode pointer end 0 string)
+          string))
     (declare (fixnum end))))
 
@@ -640 +652 @@
 (defun %atomic-incf-symbol-value (s &optional (by 1))
   (setq s (require-type s 'symbol))
-  (let* ((binding-address (%symbol-binding-address s)))
-    (declare (fixnum binding-address))
-    (if (zerop binding-address)
-      (%atomic-incf-node by s target::symbol.vcell-cell)
-      (%atomic-incf-node by binding-address (* 2 target::node-size)))))
-
-(defun write-lock-rwlock (lock)
-  (let* ((context (%current-tcr)))
-    (if (eq (%svref lock target::lock.writer-cell) context)
-      (progn
-        (decf (%svref lock target::lock._value-cell))
-        lock)
-      (loop
-        (when (%store-immediate-conditional target::lock._value lock 0 -1)
-          (setf (%svref lock target::lock.writer-cell) context)
-          (return lock))
-        (%nanosleep 0 *ns-per-tick*)))))
-
-
-(defun read-lock-rwlock (lock)
-  (loop
-    (when (%try-read-lock-rwlock lock)
-      (return lock))
-    (%nanosleep 0 *ns-per-tick*)))
+  (multiple-value-bind (base offset) (%symbol-binding-address s)
+    (%atomic-incf-node by base offset)))
+
+;;; What happens if there are some pending readers and another writer,
+;;; and we abort out of the semaphore wait ?  If the writer semaphore is
+;;; signaled before we abandon interest in it
+(defun %write-lock-rwlock-ptr (ptr &optional flag)
+  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (incf (%get-signed-natural ptr target::rwlock.state))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (if flag
+             (setf (lock-acquisition.status flag) t))
+           t)
+         (do* ()
+              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state) 1
+                     (%get-natural ptr target::rwlock.spin) 0)
+               (%set-object ptr target::rwlock.writer tcr)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (incf (%get-natural ptr target::rwlock.blocked-writers))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (let* ((*interrupt-level* level))
+                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
+           (%get-spin-lock ptr)))))))
+
+(defun write-lock-rwlock (lock &optional flag)
+  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
+
+(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
+  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (error 'deadlock :lock lock))
+         (do* ((state
+                (%get-signed-natural ptr target::rwlock.state)
+                (%get-signed-natural ptr target::rwlock.state)))
+              ((<= state 0)
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state)
+                     (the fixnum (1- state))
+                     (%get-natural ptr target::rwlock.spin) 0)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (declare (fixnum state))
+           (incf (%get-natural ptr target::rwlock.blocked-readers))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (let* ((*interrupt-level* level))
+             (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
+           (%get-spin-lock ptr)))))))
+
+(defun read-lock-rwlock (lock &optional flag)
+  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
+
+;;; If the current thread already owns the lock for writing, increment
+;;; the lock's state.  Otherwise, try to lock the lock for reading.
+(defun %ensure-at-least-read-locked (lock &optional flag)
+  (if (istruct-typep flag 'lock-acquisition)
+    (setf (lock-acquisition.status flag) nil)
+    (if flag (report-bad-arg flag 'lock-acquisition)))
+  (let* ((ptr (read-write-lock-ptr lock))
+         (tcr (%current-tcr)))
+    (declare (fixnum tcr))
+    (or
+     (without-interrupts
+      (%get-spin-lock ptr)
+      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
+        (declare (fixnum state))
+        (let ((win
+               (cond ((<= state 0)
+                      (setf (%get-signed-natural ptr target::rwlock.state)
+                            (the fixnum (1- state)))
+                      t)
+                     ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
+                      (setf (%get-signed-natural ptr target::rwlock.state)
+                            (the fixnum (1+ state)))
+                      t))))
+          (setf (%get-natural ptr target::rwlock.spin) 0)
+          (when win
+            (if flag
+              (setf (lock-acquisition.status flag) t))
+            t))))
+       (%read-lock-rwlock-ptr ptr lock flag))))
+
+(defun %unlock-rwlock-ptr (ptr lock)
+  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
+                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
+    (without-interrupts
+     (%get-spin-lock ptr)
+     (let* ((state (%get-signed-natural ptr target::rwlock.state))
+            (tcr (%current-tcr)))
+       (declare (fixnum state tcr))
+       (cond ((> state 0)
+              (unless (eql tcr (%get-object ptr target::rwlock.writer))
+                (setf (%get-natural ptr target::rwlock.spin) 0)
+                (error 'not-lock-owner :lock lock))
+              (decf state))
+             ((< state 0) (incf state))
+             (t (setf (%get-natural ptr target::rwlock.spin) 0)
+                (error 'not-locked :lock lock)))
+       (setf (%get-signed-natural ptr target::rwlock.state) state)
+       (when (zerop state)
+         ;; We want any thread waiting for a lock semaphore to
+         ;; be able to wait interruptibly.  When a thread waits,
+         ;; it increments either the "blocked-readers" or "blocked-writers"
+         ;; field, but since it may get interrupted before obtaining
+         ;; the semaphore that's more of "an expression of interest"
+         ;; in taking the lock than it is "a firm commitment to take it."
+         ;; It's generally (much) better to signal the semaphore(s)
+         ;; too often than it would be to not signal them often
+         ;; enough; spurious wakeups are better than deadlock.
+         ;; So: if there are blocked writers, the writer-signal
+         ;; is raised once for each apparent blocked writer.  (At most
+         ;; one writer will actually succeed in taking the lock.)
+         ;; If there are blocked readers, the reader-signal is raised
+         ;; once for each of them.  (It's possible for both the
+         ;; reader and writer semaphores to be raised on the same
+         ;; unlock; the writer semaphore is raised first, so in that
+         ;; sense, writers still have priority but it's not guaranteed.)
+         ;; Both the "blocked-writers" and "blocked-readers" fields
+         ;; are cleared here (they can't be changed from another thread
+         ;; until this thread releases the spinlock.)
+         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
+         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
+                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
+           (declare (fixnum nreaders nwriters))
+           (when (> nwriters 0)
+             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
+             (dotimes (i nwriters)
+               (%signal-semaphore-ptr writer-signal)))
+           (when (> nreaders 0)
+             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
+             (dotimes (i nreaders)
+               (%signal-semaphore-ptr reader-signal)))))
+       (setf (%get-natural ptr target::rwlock.spin) 0)
+       t))))
+
+(defun unlock-rwlock (lock)
+  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
+
+;;; There are all kinds of ways to lose here.
+;;; The caller must have read access to the lock exactly once,
+;;; or have write access.
+;;; there's currently no way to detect whether the caller has
+;;; read access at all.
+;;; If we have to block and get interrupted, cleanup code may
+;;; try to unlock a lock that we don't hold. (It might be possible
+;;; to circumvent that if we use the same notifcation object here
+;;; that controls that cleanup process.)
+
+(defun %promote-rwlock (lock &optional flag)
+  (let* ((ptr (read-write-lock-ptr lock)))
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (without-interrupts
+       (%get-spin-lock ptr)
+       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
+         (declare (fixnum state))
+         (cond ((> state 0)
+                (unless (eql (%get-object ptr target::rwlock.writer) tcr)
+                  (setf (%get-natural ptr target::rwlock.spin) 0)
+                  (error :not-lock-owner :lock lock)))
+               ((= state 0)
+                  (setf (%get-natural ptr target::rwlock.spin) 0)
+                  (error :not-locked :lock lock))
+               (t
+                (if (= state -1)
+                  (progn
+                    (setf (%get-signed-natural ptr target::rwlock.state) 1
+                          (%get-natural ptr target::rwlock.spin) 0)
+                    (%set-object ptr target::rwlock.writer tcr)
+                    (if flag
+                      (setf (lock-acquisition.status flag) t))
+                    t)
+                  (progn
+                    (%unlock-rwlock-ptr ptr lock)
+                    (let* ((*interrupt-level* level))
+                      (%write-lock-rwlock-ptr ptr flag)))))))))))
+                      
+               
+           
+           
+  
+
 
 (defun safe-get-ptr (p &optional dest)