X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=9891317beabdcf76ffb6ca6dd066535790091a74;hb=d25e3478acccec70402ff32554669a982be8e281;hp=1738fbdcc636da9ed9b4b319ecd30e0f7e99a678;hpb=08d05510b51708853ca998154d8096b21d85edab;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 1738fbd..9891317 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -516,6 +516,10 @@ (init-wrapper 'progn) (values 1)) (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 +529,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,20 +559,16 @@ (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*")))) + `((incf ,probes-name))) (let* ((,n-index (,hash-function ,@(arg-vars))) (,n-cache ,var-name) (,args-and-values (svref ,n-cache ,n-index))) @@ -577,7 +577,7 @@ (values ,@(values-refs))) (t ,@(when *profile-hash-cache* - `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) + `((incf ,misses-name))) ,default)))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) @@ -603,6 +603,9 @@ `(progn (defvar ,var-name) + ,@(when *profile-hash-cache* + `((defvar ,probes-name) + (defvar ,misses-name))) (declaim (type (simple-vector ,size) ,var-name)) #!-sb-fluid (declaim (inline ,@(inlines))) (,init-wrapper ,@(inits)) @@ -769,33 +772,43 @@ ;;; 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)) +(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind) (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)))))) + (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 action (describe-action) new-value spec) + :datum new-value + :expected-type spec)))))))) (values)) ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary @@ -878,18 +891,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