X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=bde43c174e916d2b50bd99956f47ff228ef65eb5;hb=a6a12ed609d5467ec43b411283e5b3568fee81df;hp=1738fbdcc636da9ed9b4b319ecd30e0f7e99a678;hpb=08d05510b51708853ca998154d8096b21d85edab;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 1738fbd..bde43c1 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -13,6 +13,14 @@ (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")) @@ -453,7 +461,7 @@ ,@forms))))) `(let ((,n-table ,table)) ,(if locked - `(with-locked-hash-table (,n-table) + `(with-locked-system-table (,n-table) ,iter-form) iter-form)))))) @@ -512,10 +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**"))) + (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)) @@ -525,7 +543,7 @@ (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)) @@ -555,37 +573,36 @@ (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)) @@ -594,16 +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) - (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) @@ -757,47 +777,6 @@ (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) ..)) @@ -878,18 +857,18 @@ ;;; guts of complex systems anyway, I replaced it too.) (defmacro aver (expr) `(unless ,expr - (%failed-aver ,(format nil "~A" expr)))) + (%failed-aver ',expr))) -(defun %failed-aver (expr-as-string) +(defun %failed-aver (expr) ;; hackish way to tell we're in a cold sbcl and output the - ;; message before signallign error, as it may be this is too + ;; message before signalling error, as it may be this is too ;; early in the cold init. (when (find-package "SB!C") (fresh-line) (write-line "failed AVER:") - (write-line expr-as-string) + (write expr) (terpri)) - (bug "~@" expr-as-string)) + (bug "~@" expr)) (defun bug (format-control &rest format-arguments) (error 'bug @@ -942,7 +921,7 @@ ;;; 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) @@ -956,7 +935,10 @@ ((: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)))) + ;;;; utilities for two-VALUES predicates @@ -1105,10 +1087,104 @@ (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::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)