X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=5ea36699fb622d168f1cebfabe37e5c173069fc2;hb=beddcfe1ea23d2cfdddde2fa7cde6436799715a2;hp=042ab05e61b5c9d48d148f7c73998af5437980fb;hpb=9d66a077cc98384aa6c1be0d1178b3c82f66e5e8;p=sbcl.git

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index 042ab05..5ea3669 100644
--- 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)))
 
 ;;;; SUB-GC
 
@@ -219,7 +243,7 @@ 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)
@@ -292,7 +316,8 @@ run in any thread.")
 
 (define-alien-routine scrub-control-stack sb!alien:void)
 
-(defun unsafe-clear-roots ()
+(defun unsafe-clear-roots (gen)
+  #!-gencgc (declare (ignore 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.
@@ -300,10 +325,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))
 
 ;;;; auxiliary functions