armload of DEFINE-HASH-CACHE changes

[sbcl.git] / src / code / gc.lisp

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index 8839b3e..fb4a0e1 100644 (file)
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -156,6 +156,30 @@ run in any thread.")
   (defun gc-stop-the-world ())
   (defun gc-start-the-world ()))
 
+#!+gencgc
+(progn
+  (sb!alien:define-alien-variable ("gc_logfile" %gc-logfile) (* char))
+  (defun (setf gc-logfile) (pathname)
+    "Use PATHNAME to log garbage collections. If non-null, the
+designated file is opened before and after each collection, and
+generation statistics are appended to it. To stop writing the log, use
+NIL as the pathname."
+    (let ((new (when pathname
+                 (sb!alien:make-alien-string
+                  (native-namestring (translate-logical-pathname pathname)
+                                     :as-file t))))
+          (old %gc-logfile))
+      (setf %gc-logfile new)
+      (when old
+        (sb!alien:free-alien old))))
+  (defun gc-logfile ()
+    "Return the name of the current GC logfile."
+    (let ((val %gc-logfile))
+      (when val
+        (native-pathname (cast val c-string)))))
+  (declaim (inline dynamic-space-size))
+  (defun dynamic-space-size ()
+    (sb!alien:extern-alien "dynamic_space_size" sb!alien:unsigned-long)))
 \f
 ;;;; SUB-GC
 
@@ -219,13 +243,18 @@ run in any thread.")
                (let ((*gc-inhibit* t))
                  (let ((old-usage (dynamic-usage))
                        (new-usage 0))
-                   (unsafe-clear-roots)
+                   (unsafe-clear-roots gen)
                    (gc-stop-the-world)
                    (let ((start-time (get-internal-run-time)))
                      (collect-garbage gen)
                      (setf *gc-epoch* (cons nil nil))
-                     (incf *gc-run-time*
-                           (- (get-internal-run-time) start-time)))
+                     (let ((run-time (- (get-internal-run-time) start-time)))
+                       ;; KLUDGE: Sometimes we see the second getrusage() call
+                       ;; return a smaller value than the first, which can
+                       ;; lead to *GC-RUN-TIME* to going negative, which in
+                       ;; turn is a type-error.
+                       (when (plusp run-time)
+                         (incf *gc-run-time* run-time))))
                    (setf *gc-pending* nil
                          new-usage (dynamic-usage))
                    #!+sb-thread
@@ -287,7 +316,7 @@ run in any thread.")
 
 (define-alien-routine scrub-control-stack sb!alien:void)
 
-(defun unsafe-clear-roots ()
+(defun unsafe-clear-roots (gen)
   ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
   ;; as having these cons more then we have space left leads to huge
   ;; badness.
@@ -295,10 +324,15 @@ run in any thread.")
   ;; Power cache of the bignum printer: drops overly large bignums and
   ;; removes duplicate entries.
   (scrub-power-cache)
-  ;; FIXME: CTYPE-OF-CACHE-CLEAR isn't thread-safe.
-  #!-sb-thread
-  (ctype-of-cache-clear))
-
+  ;; Clear caches depending on the generation being collected.
+  #!+gencgc
+  (cond ((eql 0 gen))
+        ((eql 1 gen)
+         (ctype-of-cache-clear))
+        (t
+         (drop-all-hash-caches)))
+  #!-gencgc
+  (drop-all-hash-caches))
 \f
 ;;;; auxiliary functions
 
@@ -346,7 +380,9 @@ collection is initiated. This can be set with SETF."
             (number-of-gcs int)
             (number-of-gcs-before-promotion int)
             (cum-sum-bytes-allocated unsigned-long)
-            (minimum-age-before-gc double)))
+            (minimum-age-before-gc double)
+            ;; `struct lutex *' or `void *', depending.
+            (lutexes (* char))))
 
 #!+gencgc
 (define-alien-variable generations