(in-package "SB!IMPL")
+(defvar *core-pathname* nil
+ #!+sb-doc
+ "The absolute pathname of the running SBCL core.")
+
+(defvar *runtime-pathname* nil
+ #!+sb-doc
+ "The absolute pathname of the running SBCL runtime.")
+
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
,@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**")))
+ (misses-name (when *profile-hash-cache*
+ (symbolicate "**" name "-CACHE-MISSES**")))
(nargs (length args))
(size (ash 1 hash-bits))
(default-values (if (and (consp default) (eq (car default) 'values))
(args-and-values-size (+ nargs values))
(n-index (sb!xc:gensym "INDEX"))
(n-cache (sb!xc:gensym "CACHE")))
-
+ (declare (ignorable probes-name misses-name))
(unless (= (length default-values) values)
(error "The number of default values ~S differs from :VALUES ~W."
default values))
(incf n)))
(when *profile-hash-cache*
- (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
- (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
- (inits `(setq ,n-probe 0))
- (inits `(setq ,n-miss 0))
- (forms `(defvar ,n-probe))
- (forms `(defvar ,n-miss))
- (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+ (inits `(setq ,probes-name 0))
+ (inits `(setq ,misses-name 0))
+ (forms `(declaim (fixnum ,probes-name ,misses-name))))
(let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
(inlines fun-name)
(forms
`(defun ,fun-name ,(arg-vars)
,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
- (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
+ `((incf ,probes-name)))
+ (flet ((miss ()
,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
- ,default))))))
+ `((incf ,misses-name)))
+ (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)
- (declaim (type (simple-vector ,size) ,var-name))
+ (pushnew ',var-name *cache-vector-symbols*)
+ (defglobal ,var-name nil)
+ ,@(when *profile-hash-cache*
+ `((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))
- (declare (symbol symbol))
- (multiple-value-bind (what continue)
- (when (eq :constant (info :variable :kind symbol))
- (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))))
- (when what
- (if continue
- (cerror "Modify the constant." what action symbol)
- (error what 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)
- (let ((spec (type-specifier type)))
- (error 'simple-type-error
- :format-control "Cannot ~@? to ~S (not of type ~S.)"
- :format-arguments (list 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
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
-(defun deprecation-warning (bad-name &optional good-name)
- (warn "using deprecated ~S~@[, should use ~S instead~]"
- bad-name
- good-name))
+;;;; Deprecating stuff
+
+(defun normalize-deprecation-replacements (replacements)
+ (if (or (not (listp replacements))
+ (eq 'setf (car replacements)))
+ (list replacements)
+ replacements))
+
+(defun deprecation-error (since name replacements)
+ (error 'deprecation-error
+ :name name
+ :replacements (normalize-deprecation-replacements replacements)
+ :since since))
+
+(defun deprecation-warning (state since name replacements
+ &key (runtime-error (neq :early state)))
+ (warn (ecase state
+ (:early 'early-deprecation-warning)
+ (:late 'late-deprecation-warning)
+ (:final 'final-deprecation-warning))
+ :name name
+ :replacements (normalize-deprecation-replacements replacements)
+ :since since
+ :runtime-error runtime-error))
+
+(defun deprecated-function (since name replacements)
+ (lambda (&rest deprecated-function-args)
+ (declare (ignore deprecated-function-args))
+ (deprecation-error since name replacements)))
+
+(defun deprecation-compiler-macro (state since name replacements)
+ (lambda (form env)
+ (declare (ignore env))
+ (deprecation-warning state since name replacements)
+ form))
+
+;;; STATE is one of
+;;;
+;;; :EARLY, for a compile-time style-warning.
+;;; :LATE, for a compile-time full warning.
+;;; :FINAL, for a compile-time full warning and runtime error.
+;;;
+;;; Suggested duration of each stage is one year, but some things can move faster,
+;;; and some widely used legacy APIs might need to move slower. Internals we don't
+;;; usually add deprecation notes for, but sometimes an internal API actually has
+;;; several external users, in which case we try to be nice about it.
+;;;
+;;; When you deprecate something, note it here till it is fully gone: makes it
+;;; easier to keep things progressing orderly. Also add the relevant section
+;;; (or update it when deprecation proceeds) in the manual, in
+;;; deprecated.texinfo.
+;;;
+;;; EARLY:
+;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013
+;;; ^- initially deprecated without compile-time warning, hence the schedule
+;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-RECURSIVE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::GET-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::RELEASE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-VALUE, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SETF SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011) -> Late: 11/2012
+;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;;
+;;; LATE:
+;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007) -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-INTROSPECT:FUNCTION-ARGLIST, since 1.0.24.5 (01/2009) -> Final: anytime
+;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012
+;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012
+
+(defmacro define-deprecated-function (state since name replacements lambda-list &body body)
+ (let* ((replacements (normalize-deprecation-replacements replacements))
+ (doc (let ((*package* (find-package :keyword)))
+ (apply #'format nil
+ "~@<~S has been deprecated as of SBCL ~A.~
+ ~#[~; Use ~S instead.~; ~
+ Use ~S or ~S instead.~:; ~
+ Use~@{~#[~; or~] ~S~^,~} instead.~]~@:>"
+ name since replacements))))
+ `(progn
+ ,(ecase state
+ ((:early :late)
+ `(defun ,name ,lambda-list
+ ,doc
+ ,@body))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ',name ',replacements ,since))
+ (setf (documentation ',name 'function) ,doc))))
+ (setf (compiler-macro-function ',name)
+ (deprecation-compiler-macro ,state ,since ',name ',replacements)))))
;;; Anaphoric macros
(defmacro awhen (test &body body)
(if (eql x 0.0l0)
(make-unportable-float :long-float-negative-zero)
0.0l0))))
+
+;;; Like DEFUN, but replaces &REST with &MORE while hiding that from the
+;;; lambda-list.
+(defmacro define-more-fun (name lambda-list &body body)
+ (let* ((p (position '&rest lambda-list))
+ (head (subseq lambda-list 0 p))
+ (tail (subseq lambda-list p))
+ (more-context (gensym "MORE-CONTEXT"))
+ (more-count (gensym "MORE-COUNT")))
+ (aver (= 2 (length tail)))
+ `(progn
+ (macrolet ((more-count ()
+ `(truly-the index ,',more-count))
+ (more-p ()
+ `(not (eql 0 ,',more-count)))
+ (more-arg (n)
+ `(sb!c:%more-arg ,',more-context ,n))
+ (do-more ((arg &optional (start 0)) &body body)
+ (let ((i (gensym "I")))
+ `(do ((,i (the index ,start) (truly-the index (1+ ,i))))
+ ((>= ,i (more-count)))
+ (declare (index ,i))
+ (let ((,arg (sb!c:%more-arg ,',more-context ,i)))
+ ,@body)))))
+ (defun ,name (,@head &more ,more-context ,more-count)
+ ,@body))
+ (setf (%simple-fun-arglist #',name) ',lambda-list))))
projects / sbcl.git / blobdiff