From 4084b6b95c1d5e0a45e073a9b875d8471efd8505 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 7 Jun 2011 17:08:00 +0300 Subject: [PATCH] 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. --- package-data-list.lisp-expr | 1 + src/code/early-extensions.lisp | 49 ++++++++++++++++++++++++---------------- src/code/early-type.lisp | 3 +-- src/code/gc.lisp | 17 +++++++++----- src/code/save.lisp | 3 ++- src/code/target-type.lisp | 16 ++++--------- 6 files changed, 48 insertions(+), 41 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 642edff..80a6f61 100644 --- 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 --- 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 --- 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)) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 50226ab..fb4a0e1 100644 --- 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)) ;;;; auxiliary functions diff --git a/src/code/save.lisp b/src/code/save.lisp index ed323a7..c3ebfb9 100644 --- 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 --- 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 -- 1.7.10.4