,@forms)))))
`(let ((,n-table ,table))
,(if locked
- `(with-locked-hash-table (,n-table)
+ `(with-locked-system-table (,n-table)
,iter-form)
iter-form))))))
\f
;;; 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))
`(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))
(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)
(char= #\* (aref name 0))
(char= #\* (aref name (1- (length name))))))))
-;;; This function is to be called just before a change which would affect the
-;;; symbol value. We don't absolutely have to call this function before such
-;;; changes, since such changes to constants are given as undefined behavior,
-;;; it's nice to do so. To circumvent this you need code like this:
-;;;
-;;; (defvar foo)
-;;; (defun set-foo (x) (setq foo x))
-;;; (defconstant foo 42)
-;;; (set-foo 13)
-;;; foo => 13, (constantp 'foo) => t
-;;;
-;;; ...in which case you frankly deserve to lose.
-(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind)
- (declare (symbol symbol))
- (flet ((describe-action ()
- (ecase action
- (set "set SYMBOL-VALUE of ~S")
- (progv "bind ~S")
- (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
- (defconstant "define ~S as a constant")
- (makunbound "make ~S unbound"))))
- (let ((kind (info :variable :kind symbol)))
- (multiple-value-bind (what continue)
- (cond ((eq :constant kind)
- (cond ((eq symbol t)
- (values "Veritas aeterna. (can't ~@?)" nil))
- ((eq symbol nil)
- (values "Nihil ex nihil. (can't ~@?)" nil))
- ((keywordp symbol)
- (values "Can't ~@?." nil))
- (t
- (values "Constant modification: attempt to ~@?." t))))
- ((and bind (eq :global kind))
- (values "Can't ~@? (global variable)." nil)))
- (when what
- (if continue
- (cerror "Modify the constant." what (describe-action) symbol)
- (error what (describe-action) symbol)))
- (when valuep
- ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
- ;; check.
- (let ((type (info :variable :type symbol)))
- (unless (sb!kernel::%%typep new-value type nil)
- (let ((spec (type-specifier type)))
- (error 'simple-type-error
- :format-control "~@<Cannot ~@? to ~S, not of type ~S.~:@>"
- :format-arguments (list (describe-action) symbol new-value spec)
- :datum new-value
- :expected-type spec))))))))
- (values))
-
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
;;; assignment instead of doing cold static linking. That way things like
;;; (FLET ((FROB (X) ..))
;;; If X is a symbol, see whether it is present in *FEATURES*. Also
;;; handle arbitrary combinations of atoms using NOT, AND, OR.
(defun featurep (x)
- (etypecase x
+ (typecase x
(cons
(case (car x)
((:not not)
((:or or) (some #'featurep (cdr x)))
(t
(error "unknown operator in feature expression: ~S." x))))
- (symbol (not (null (memq x *features*))))))
+ (symbol (not (null (memq x *features*))))
+ (t
+ (error "invalid feature expression: ~S" x))))
+
\f
;;;; utilities for two-VALUES predicates
projects / sbcl.git / blobdiff