armload of DEFINE-HASH-CACHE changes

 * To clear a cache, drop the entire vector instead of filling it with
   NILs: thread safe, less work, and doesn't add dirty pages to old
   generations.

   Entering a value after the cache has been dropped allocates a new
   one.

   Caches are now initialized with 0 instead of NIL -- faster to
   allocate.

 * Use DEFGLOBAL instead of DEFVAR.

 * SAVE-LISP-AND-DIE drops all caches.

 * UNSAFE-CLEAR-ROOTS drops caches depending on the depth of the
   collection: nursery collection keeps all caches, gen 1 collection
   drops the CTYPE-OF cache, gen 2 and deeper collections drop all
   caches.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 642edff..80a6f61 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1082,6 +1082,7 @@ possibly temporariliy, because it might be used internally."
                "DEFINE-HASH-CACHE"
                "DEFUN-CACHED"
                "DEFINE-CACHED-SYNONYM"
+               "DROP-ALL-HASH-CACHES"
 
                ;; time
                "FORMAT-DECODED-TIME"

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 5f2aa46..b35eb8e 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -520,14 +520,20 @@
 ;;;   the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
 ;;;   in type system definitions so that caches will be created
 ;;;   before top level forms run.)
+(defvar *cache-vector-symbols* nil)
+
+(defun drop-all-hash-caches ()
+  (dolist (name *cache-vector-symbols*)
+    (set name nil)))
+
 (defmacro define-hash-cache (name args &key hash-function hash-bits default
                                   (init-wrapper 'progn)
                                   (values 1))
-  (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+  (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**"))
          (probes-name (when *profile-hash-cache*
-                       (symbolicate "*" name "-CACHE-PROBES*")))
+                       (symbolicate "**" name "-CACHE-PROBES**")))
          (misses-name (when *profile-hash-cache*
-                      (symbolicate "*" name "-CACHE-MISSES*")))
+                      (symbolicate "**" name "-CACHE-MISSES**")))
          (nargs (length args))
          (size (ash 1 hash-bits))
          (default-values (if (and (consp default) (eq (car default) 'values))
@@ -577,23 +583,26 @@
          `(defun ,fun-name ,(arg-vars)
             ,@(when *profile-hash-cache*
                 `((incf ,probes-name)))
-            (let* ((,n-index (,hash-function ,@(arg-vars)))
-                   (,n-cache ,var-name)
-                   (,args-and-values (svref ,n-cache ,n-index)))
-              (cond ((and ,args-and-values
-                          ,@(tests))
-                     (values ,@(values-refs)))
-                    (t
+            (flet ((miss ()
                      ,@(when *profile-hash-cache*
                          `((incf ,misses-name)))
-                     ,default))))))
+                     (return-from ,fun-name ,default)))
+              (let* ((,n-index (,hash-function ,@(arg-vars)))
+                     (,n-cache (or ,var-name (miss)))
+                     (,args-and-values (svref ,n-cache ,n-index)))
+                (cond ((and (not (eql 0 ,args-and-values))
+                            ,@(tests))
+                       (values ,@(values-refs)))
+                      (t
+                       (miss))))))))
 
       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
         (inlines fun-name)
         (forms
          `(defun ,fun-name (,@(arg-vars) ,@(values-names))
             (let ((,n-index (,hash-function ,@(arg-vars)))
-                  (,n-cache ,var-name)
+                  (,n-cache (or ,var-name
+                                (setq ,var-name (make-array ,size :initial-element 0))))
                   (,args-and-values (make-array ,args-and-values-size)))
               ,@(sets)
               (setf (svref ,n-cache ,n-index) ,args-and-values))
@@ -602,19 +611,19 @@
       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
         (forms
          `(defun ,fun-name ()
-            (fill ,var-name nil)))
-        (forms `(,fun-name)))
+            (setq ,var-name nil))))
 
-      (inits `(unless (boundp ',var-name)
-                (setq ,var-name (make-array ,size :initial-element nil))))
+      ;; Needed for cold init!
+      (inits `(setq ,var-name nil))
       #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
 
       `(progn
-         (defvar ,var-name)
+         (pushnew ',var-name *cache-vector-symbols*)
+         (defglobal ,var-name nil)
          ,@(when *profile-hash-cache*
-             `((defvar ,probes-name)
-               (defvar ,misses-name)))
-         (declaim (type (simple-vector ,size) ,var-name))
+             `((defglobal ,probes-name 0)
+               (defglobal ,misses-name 0)))
+         (declaim (type (or null (simple-vector ,size)) ,var-name))
          #!-sb-fluid (declaim (inline ,@(inlines)))
          (,init-wrapper ,@(inits))
          ,@(forms)

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index a4160a2..ec513da 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -698,8 +698,7 @@ Experimental."
 (defun %note-type-defined (name)
   (declare (symbol name))
   (note-name-defined name :type)
-  (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
-    (values-specifier-type-cache-clear))
+  (values-specifier-type-cache-clear)
   (values))
 
 \f

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index 50226ab..fb4a0e1 100644 (file)
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -243,7 +243,7 @@ NIL as the pathname."
                (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)
@@ -316,7 +316,7 @@ NIL as the pathname."
 
 (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.
@@ -324,10 +324,15 @@ NIL as the pathname."
   ;; 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
 

diff --git a/src/code/save.lisp b/src/code/save.lisp
index ed323a7..c3ebfb9 100644 (file)
--- a/src/code/save.lisp
+++ b/src/code/save.lisp
@@ -175,4 +175,5 @@ sufficiently motivated to do lengthy fixes."
   (debug-deinit)
   (foreign-deinit)
   (stream-deinit)
-  (deinit-finalizers))
+  (deinit-finalizers)
+  (drop-all-hash-caches))

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index a3775fb..5bff4bd 100644 (file)
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -130,19 +130,11 @@
 ;;; Clear memoization of all type system operations that can be
 ;;; altered by type definition/redefinition.
 ;;;
-;;; FIXME: This should be autogenerated.
 (defun clear-type-caches ()
-  (declare (special *type-system-initialized*))
-  (when *type-system-initialized*
-    (dolist (sym '(values-specifier-type-cache-clear
-                   values-type-union-cache-clear
-                   type-union2-cache-clear
-                   values-subtypep-cache-clear
-                   csubtypep-cache-clear
-                   type-intersection2-cache-clear
-                   values-type-intersection-cache-clear
-                   type=-cache-clear))
-      (funcall (the function (symbol-function sym)))))
+  ;; FIXME: We would like to differentiate between different cache
+  ;; kinds, but at the moment all our caches pretty much are type
+  ;; caches.
+  (drop-all-hash-caches)
   (values))
 
 ;;; This is like TYPE-OF, only we return a CTYPE structure instead of