(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"))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant max-hash sb!xc:most-positive-fixnum))
+
+(def!type hash ()
+ `(integer 0 ,max-hash))
+
;;; a type used for indexing into arrays, and for related quantities
;;; like lengths of lists
;;;
;;; if the table is a synchronized table.
(defmacro dohash (((key-var value-var) table &key result locked) &body body)
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
- (let* ((gen (gensym))
- (n-more (gensym))
- (n-table (gensym))
- (iter-form `(with-hash-table-iterator (,gen ,n-table)
+ (with-unique-names (gen n-more n-table)
+ (let ((iter-form `(with-hash-table-iterator (,gen ,n-table)
(loop
(multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
,@decls
(unless ,n-more (return ,result))
,@forms)))))
- `(let ((,n-table ,table))
- ,(if locked
- `(with-locked-hash-table (,n-table)
- ,iter-form)
- iter-form)))))
+ `(let ((,n-table ,table))
+ ,(if locked
+ `(with-locked-system-table (,n-table)
+ ,iter-form)
+ iter-form))))))
\f
;;;; hash cache utility
;;; 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))
(cdr default)
(list default)))
- (args-and-values (gensym))
+ (args-and-values (sb!xc:gensym "ARGS-AND-VALUES"))
(args-and-values-size (+ nargs values))
- (n-index (gensym))
- (n-cache (gensym)))
-
+ (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))
(values-refs)
(values-names))
(dotimes (i values)
- (let ((name (gensym)))
+ (let ((name (sb!xc:gensym "VALUE")))
(values-names name)
(values-refs `(svref ,args-and-values (+ ,nargs ,i)))
(sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name))))
(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)
(let ((default-values (if (and (consp default) (eq (car default) 'values))
(cdr default)
(list default)))
- (arg-names (mapcar #'car args)))
- (collect ((values-names))
- (dotimes (i values)
- (values-names (gensym)))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- `(progn
- (define-hash-cache ,name ,args ,@options)
- (defun ,name ,arg-names
- ,@decls
- ,doc
- (cond #!+sb-show
- ((not (boundp '*hash-caches-initialized-p*))
- ;; This shouldn't happen, but it did happen to me
- ;; when revising the type system, and it's a lot
- ;; easier to figure out what what's going on with
- ;; that kind of problem if the system can be kept
- ;; alive until cold boot is complete. The recovery
- ;; mechanism should definitely be conditional on
- ;; some debugging feature (e.g. SB-SHOW) because
- ;; it's big, duplicating all the BODY code. -- WHN
- (/show0 ,name " too early in cold init, uncached")
- (/show0 ,(first arg-names) "=..")
- (/hexstr ,(first arg-names))
- ,@body)
- (t
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar (lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))))
+ (arg-names (mapcar #'car args))
+ (values-names (make-gensym-list values)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on some
+ ;; debugging feature (e.g. SB-SHOW) because it's big,
+ ;; duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,values-names
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ values-names default-values))
+ (multiple-value-bind ,values-names
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@values-names)
+ (values ,@values-names))
+ (values ,@values-names))))))))))
(defmacro define-cached-synonym
(name &optional (original (symbolicate "%" name)))
(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)
- (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))))
- (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) ..))
(unless (proper-list-of-length-p spec 2)
(error "malformed ONCE-ONLY binding spec: ~S" spec))
(let* ((name (first spec))
- (exp-temp (gensym (symbol-name name))))
+ (exp-temp (gensym "ONCE-ONLY")))
`(let ((,exp-temp ,(second spec))
- (,name (gensym "ONCE-ONLY-")))
+ (,name (gensym ,(symbol-name name))))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
\f
;;; 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 "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+ (bug "~@<failed AVER: ~2I~_~A~:>" expr))
(defun bug (format-control &rest format-arguments)
(error 'bug
;;; 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
(let ((first? t)
maybe-print-space
(reversed-prints nil)
- (stream (gensym "STREAM")))
+ (stream (sb!xc:gensym "STREAM")))
(flet ((sref (slot-name)
`(,(symbolicate conc-name slot-name) structure)))
(dolist (slot-desc slot-descs)
(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))
+
+(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)
(*print-length* (or (true *print-length*) 12)))
(funcall function))))
+;;; Returns a list of members of LIST. Useful for dealing with circular lists.
+;;; For a dotted list returns a secondary value of T -- in which case the
+;;; primary return value does not include the dotted tail.
+(defun list-members (list)
+ (when list
+ (do ((tail (cdr list) (cdr tail))
+ (members (list (car list)) (cons (car tail) members)))
+ ((or (not (consp tail)) (eq tail list))
+ (values members (not (listp tail)))))))
+
;;; Default evaluator mode (interpeter / compiler)
(declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
;;; Helper for making the DX closure allocation in macros expanding
;;; to CALL-WITH-FOO less ugly.
-;;;
-;;; This expands to something like
-;;;
-;;; (flet ((foo (...) <body-of-foo>))
-;;; (declare (optimize stack-allocate-dynamic-extent))
-;;; (flet ((foo (...)
-;;; (foo ...))
-;;; (declare (dynamic-extent #'foo))
-;;; <body-of-dx-flet>)))
-;;;
-;;; The outer FLETs are inlined into the inner ones, and the inner ones
-;;; are DX-allocated. The double-fletting is done to keep the bodies of
-;;; the functions in an environment with correct policy: we don't want
-;;; to force DX allocation in their bodies, which would be bad eg.
-;;; in safe code.
(defmacro dx-flet (functions &body forms)
- (let ((names (mapcar #'car functions)))
- `(flet ,functions
- #-sb-xc-host
- (declare (optimize sb!c::stack-allocate-dynamic-extent))
- (flet ,(mapcar
- (lambda (f)
- (let ((args (cadr f))
- (name (car f)))
- (when (intersection args sb!xc:lambda-list-keywords)
- ;; No fundamental reason not to support them, but we
- ;; don't currently need them here.
- (error "Non-required arguments not implemented for DX-FLET."))
- `(,name ,args
- (,name ,@args))))
- functions)
- (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names)))
- ,@forms))))
-
-;;; Another similar one -- but actually touches the policy of the body,
-;;; so take care with this one...
+ `(flet ,functions
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (func) `(function ,(car func))) functions)))
+ ,@forms))
+
+;;; Another similar one.
(defmacro dx-let (bindings &body forms)
- `(locally
- (declare (optimize #-sb-xc-host sb!c::stack-allocate-dynamic-extent
- #-sb-xc-host sb!c::stack-allocate-value-cells))
- (let ,bindings
- (declare (dynamic-extent ,@(mapcar (lambda (bind)
- (if (consp bind)
- (car bind)
- bind))
- bindings)))
- ,@forms)))
+ `(let ,bindings
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind))
+ bindings)))
+ ,@forms))
(in-package "SB!KERNEL")
projects / sbcl.git / blobdiff