#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (class-info-name x)))))
+ (prin1 (class-info-name x) s))))
(:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
(new-type-info
(make-type-info :name ',type
:class class-info
- :number new-type-number)))
+ :number new-type-number
+ :type ',type-spec)))
(setf (aref *info-types* new-type-number) new-type-info)
(push new-type-info (class-info-types class-info)))))
- ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
- ;; at cold load time. (They can't very well be set at
- ;; cross-compile time, since they differ between the
- ;; cross-compiler and the target. The DEFAULT slot values
- ;; differ because they're compiled closures, and the TYPE slot
- ;; values differ in the use of SB!XC symbols instead of CL
- ;; symbols.)
+ ;; Arrange for TYPE-INFO-DEFAULT and
+ ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load
+ ;; time. (They can't very well be set at cross-compile time,
+ ;; since they differ between host and target and are
+ ;; host-compiled closures.)
(push `(let ((type-info (type-info-or-lose ,',class ,',type)))
(setf (type-info-validate-function type-info)
,',validate-function)
;; NIL) instead of full-blown (LAMBDA (X) NIL).
(lambda (name)
(declare (ignorable name))
- ,',default))
- (setf (type-info-type type-info) ',',type-spec))
+ ,',default)))
*!reversed-type-info-init-forms*))
',type))
\f
;;;; generic interfaces
-;;; FIXME: used only in this file, needn't be in runtime
(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
(type-number (gensym)) (value (gensym)) known-volatile)
&body body)
:element-type 'compact-info-entry))
(sorted (sort (names)
#+sb-xc-host #'<
- ;; (This MAKE-FIXNUM hack implements
- ;; pointer comparison, as explained above.)
+ ;; POINTER-HASH hack implements pointer
+ ;; comparison, as explained above.
#-sb-xc-host (lambda (x y)
- (< (%primitive make-fixnum x)
- (%primitive make-fixnum y))))))
+ (< (pointer-hash x)
+ (pointer-hash y))))))
(/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
(let ((entries-idx 0))
(dolist (types sorted)
;;;
;;; We return the new value so that this can be conveniently used in a
;;; SETF function.
-(defun set-info-value (name0 type new-value
- &optional (env (get-write-info-env)))
- (declare (type type-number type) (type volatile-info-env env)
- (inline assoc))
+(defun set-info-value (name0 type new-value)
(let ((name (uncross name0)))
(when (eql name 0)
(error "0 is not a legal INFO name."))
- (with-info-bucket (table index name env)
- (let ((types (if (symbolp name)
- (assoc name (svref table index) :test #'eq)
- (assoc name (svref table index) :test #'equal))))
- (cond
- (types
- (let ((value (assoc type (cdr types))))
- (if value
- (setf (cdr value) new-value)
- (push (cons type new-value) (cdr types)))))
- (t
- (push (cons name (list (cons type new-value)))
- (svref table index))
-
- (let ((count (incf (volatile-info-env-count env))))
- (when (>= count (volatile-info-env-threshold env))
- (let ((new (make-info-environment :size (* count 2))))
- (do-info (env :name entry-name :type-number entry-num
- :value entry-val :known-volatile t)
- (set-info-value entry-name entry-num entry-val new))
- (fill (volatile-info-env-table env) nil)
- (setf (volatile-info-env-table env)
- (volatile-info-env-table new))
- (setf (volatile-info-env-threshold env)
- (volatile-info-env-threshold new)))))))))
+ (labels ((set-it (name type new-value env)
+ (declare (type type-number type)
+ (type volatile-info-env env))
+ (with-info-bucket (table index name env)
+ (let ((types (if (symbolp name)
+ (assoc name (svref table index) :test #'eq)
+ (assoc name (svref table index) :test #'equal))))
+ (cond
+ (types
+ (let ((value (assoc type (cdr types))))
+ (if value
+ (setf (cdr value) new-value)
+ (push (cons type new-value) (cdr types)))))
+ (t
+ (push (cons name (list (cons type new-value)))
+ (svref table index))
+
+ (let ((count (incf (volatile-info-env-count env))))
+ (when (>= count (volatile-info-env-threshold env))
+ (let ((new (make-info-environment :size (* count 2))))
+ (do-info (env :name entry-name :type-number entry-num
+ :value entry-val :known-volatile t)
+ (set-it entry-name entry-num entry-val new))
+ (fill (volatile-info-env-table env) nil)
+ (setf (volatile-info-env-table env)
+ (volatile-info-env-table new))
+ (setf (volatile-info-env-threshold env)
+ (volatile-info-env-threshold new)))))))))))
+ (set-it name type new-value (get-write-info-env)))
new-value))
-;;; FIXME: It should be possible to eliminate the hairy compiler macros below
-;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro
-;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the
-;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE
-;;; foldable.)
-
;;; INFO is the standard way to access the database. It's settable.
;;;
;;; Return the information of the specified TYPE and CLASS for NAME.
;;; The second value returned is true if there is any such information
;;; recorded. If there is no information, the first value returned is
;;; the default and the second value returned is NIL.
-(defun info (class type name &optional (env-list nil env-list-p))
- ;; FIXME: At some point check systematically to make sure that the
- ;; system doesn't do any full calls to INFO or (SETF INFO), or at
- ;; least none in any inner loops.
+(defun info (class type name)
(let ((info (type-info-or-lose class type)))
- (if env-list-p
- (get-info-value name (type-info-number info) env-list)
- (get-info-value name (type-info-number info)))))
-#!-sb-fluid
-(define-compiler-macro info
- (&whole whole class type name &optional (env-list nil env-list-p))
- ;; Constant CLASS and TYPE is an overwhelmingly common special case,
- ;; and we can implement it much more efficiently than the general case.
- (if (and (keywordp class) (keywordp type))
- (let ((info (type-info-or-lose class type)))
- (with-unique-names (value foundp)
- `(multiple-value-bind (,value ,foundp)
- (get-info-value ,name
- ,(type-info-number info)
- ,@(when env-list-p `(,env-list)))
- (declare (type ,(type-info-type info) ,value))
- (values ,value ,foundp))))
- whole))
-
-(defun (setf info) (new-value
- class
- type
- name
- &optional (env-list nil env-list-p))
+ (get-info-value name (type-info-number info))))
+
+(defun (setf info)
+ (new-value class type name)
(let* ((info (type-info-or-lose class type))
- (tin (type-info-number info)))
- (when (type-info-validate-function info)
- (funcall (type-info-validate-function info) name new-value))
- (if env-list-p
- (set-info-value name
- tin
- new-value
- (get-write-info-env env-list))
- (set-info-value name
- tin
- new-value)))
+ (tin (type-info-number info))
+ (validate (type-info-validate-function info)))
+ (when validate
+ (funcall validate name new-value))
+ (set-info-value name
+ tin
+ new-value))
new-value)
-#!-sb-fluid
-(progn
- ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19
- ;; does not accept them at all, and older SBCLs give a full warning.
- ;; So the easy thing is to hide this optimization from all xc hosts.
- #-sb-xc-host
- (define-compiler-macro (setf info) (&whole whole
- new-value
- class
- type
- name
- &optional (env-list nil
- env-list-p))
- ;; Constant CLASS and TYPE is an overwhelmingly common special case,
- ;; and we can resolve it much more efficiently than the general
- ;; case.
- (if (and (keywordp class) (keywordp type))
- (let* ((info (type-info-or-lose class type))
- (tin (type-info-number info)))
- (if env-list-p
- `(set-info-value ,name
- ,tin
- ,new-value
- (get-write-info-env ,env-list))
- `(set-info-value ,name
- ,tin
- ,new-value))))
- whole))
-
-;;; the maximum density of the hashtable in a volatile env (in
-;;; names/bucket)
-;;;
-;;; FIXME: actually seems to be measured in percent, should be
-;;; converted to be measured in names/bucket
-(def!constant volatile-info-environment-density 50)
-
-;;; Make a new volatile environment of the specified size.
-(defun make-info-environment (&key (size 42) (name "Unknown"))
- (declare (type (integer 1) size))
- (let ((table-size (primify (truncate (* size 100)
- volatile-info-environment-density))))
- (make-volatile-info-env :name name
- :table (make-array table-size :initial-element nil)
- :threshold size)))
;;; Clear the information of the specified TYPE and CLASS for NAME in
;;; the current environment, allowing any inherited info to become
(defun clear-info (class type name)
(let ((info (type-info-or-lose class type)))
(clear-info-value name (type-info-number info))))
-#!-sb-fluid
-(define-compiler-macro clear-info (&whole whole class type name)
- ;; Constant CLASS and TYPE is an overwhelmingly common special case, and
- ;; we can resolve it much more efficiently than the general case.
- (if (and (keywordp class) (keywordp type))
- (let ((info (type-info-or-lose class type)))
- `(clear-info-value ,name ,(type-info-number info)))
- whole))
+
(defun clear-info-value (name type)
(declare (type type-number type) (inline assoc))
(with-info-bucket (table index name (get-write-info-env))
(setf (cdr types)
(delete type (cdr types) :key #'car))
t))))
+
+;;; the maximum density of the hashtable in a volatile env (in
+;;; names/bucket)
+;;;
+;;; FIXME: actually seems to be measured in percent, should be
+;;; converted to be measured in names/bucket
+(def!constant volatile-info-environment-density 50)
+
+;;; Make a new volatile environment of the specified size.
+(defun make-info-environment (&key (size 42) (name "Unknown"))
+ (declare (type (integer 1) size))
+ (let ((table-size (primify (truncate (* size 100)
+ volatile-info-environment-density))))
+ (make-volatile-info-env :name name
+ :table (make-array table-size :initial-element nil)
+ :threshold size)))
\f
;;;; *INFO-ENVIRONMENT*
;;; has it defined, or return the default if none does. We used to
;;; do a lot of complicated caching here, but that was removed for
;;; thread-safety reasons.
-(defun get-info-value (name0 type &optional (env-list nil env-list-p))
+(defun get-info-value (name0 type)
(declare (type type-number type))
;; sanity check: If we have screwed up initialization somehow, then
;; *INFO-TYPES* could still be uninitialized at the time we try to
(aver (aref *info-types* type))
(let ((name (uncross name0)))
(flet ((lookup (env-list)
- (let ((hash nil))
- (dolist (env env-list
- (multiple-value-bind (val winp)
- (funcall (type-info-default
- (svref *info-types* type))
- name)
- (values val winp)))
- (macrolet ((frob (lookup)
- `(progn
- (setq hash (globaldb-sxhashoid name))
- (multiple-value-bind (value winp)
- (,lookup env name hash type)
- (when winp (return (values value t)))))))
- (etypecase env
- (volatile-info-env (frob volatile-info-lookup))
- (compact-info-env (frob compact-info-lookup))))))))
- (if env-list-p
- (lookup env-list)
- (lookup *info-environment*)))))
+ (dolist (env env-list
+ (multiple-value-bind (val winp)
+ (funcall (type-info-default
+ (svref *info-types* type))
+ name)
+ (values val winp)))
+ (macrolet ((frob (lookup)
+ `(let ((hash (globaldb-sxhashoid name)))
+ (multiple-value-bind (value winp)
+ (,lookup env name hash type)
+ (when winp (return (values value t)))))))
+ (etypecase env
+ (volatile-info-env (frob volatile-info-lookup))
+ (compact-info-env (frob compact-info-lookup)))))))
+ (lookup *info-environment*))))
\f
;;;; definitions for function information
:default
#+sb-xc-host (specifier-type 'function)
#-sb-xc-host (if (fboundp name)
- (specifier-type (sb!impl::%fun-type (fdefinition name)))
+ (handler-bind ((style-warning #'muffle-warning))
+ (specifier-type (sb!impl::%fun-type (fdefinition name))))
(specifier-type 'function)))
;;; the ASSUMED-TYPE for this function, if we have to infer the type
;;; where this information came from:
;;; :ASSUMED = from uses of the object
;;; :DEFINED = from examination of the definition
+;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
;;; :DECLARED = from a declaration
-;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
+;;; and :DECLARED trumps :DEFINED-METHOD.
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
-;;; and :DECLARED is useful for ANSIly specializing code which
-;;; implements the function, or which uses the function's return values.
+;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
+;;; code which implements the function, or which uses the function's
+;;; return values.
(define-info-type
:class :function
:type :where-from
- :type-spec (member :declared :assumed :defined)
+ :type-spec (member :declared :defined-method :assumed :defined)
:default
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
(define-info-type
:class :function
- :type :documentation
- :type-spec (or string null)
- :default nil)
-
-(define-info-type
- :class :function
:type :definition
:type-spec (or fdefn null)
:default nil)
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :macro :global :alien)
- :default (if (symbol-self-evaluating-p name)
+ :type-spec (member :special :constant :macro :global :alien :unknown)
+ :default (if (typep name '(or boolean keyword))
:constant
- :global))
+ :unknown))
+
+(define-info-type
+ :class :variable
+ :type :always-bound
+ :type-spec boolean
+ :default nil)
+
+(define-info-type
+ :class :variable
+ :type :deprecated
+ :type-spec t
+ :default nil)
;;; the declared type for this variable
(define-info-type
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; the Lisp object which is the value of this constant, if known
+;;; We only need a mechanism different from the
+;;; usual SYMBOL-VALUE for the cross compiler.
+#+sb-xc-host
(define-info-type
:class :variable
- :type :constant-value
+ :type :xc-constant-value
:type-spec t
- ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
- ;; Now we don't: it was the last remaining multiple-value return from
- ;; the INFO system, and bringing it down to one value lets us simplify
- ;; things, especially simplifying the declaration of return types.
- ;; Software which used to check the second value (for "is it defined
- ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
- ;; instead.
- :default (if (symbol-self-evaluating-p name)
- name
- (bug "constant lookup of nonconstant ~S" name)))
+ :default nil)
;;; the macro-expansion for symbol-macros
(define-info-type
:type-spec (or ctype null)
:default nil)
-;;; If this is a class name, then the value is a cons (NAME . CLASS),
-;;; where CLASS may be null if the class hasn't been defined yet. Note
-;;; that for built-in classes, the kind may be :PRIMITIVE and not
-;;; :INSTANCE. The name is in the cons so that we can signal a
-;;; meaningful error if we only have the cons.
-(define-info-type
- :class :type
- :type :classoid
- :type-spec (or sb!kernel::classoid-cell null)
- :default nil)
-
;;; layout for this type being used by the compiler
(define-info-type
:class :type
:default (let ((class (find-classoid name nil)))
(when class (classoid-layout class))))
+;;; DEFTYPE lambda-list
+(define-info-type
+ :class :type
+ :type :lambda-list
+ :type-spec list
+ :default nil)
+
+(define-info-type
+ :class :type
+ :type :source-location
+ :type-spec t
+ :default nil)
+
(define-info-class :typed-structure)
(define-info-type
:class :typed-structure
(when (info :type :kind name)
(error 'declaration-type-conflict-error
:format-arguments (list name)))))
+(define-info-type
+ :class :declaration
+ :type :handler
+ :type-spec (or function null))
(define-info-class :alien-type)
(define-info-type
(!cold-init-forms
(/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
(setf *info-classes*
- (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*)))
+ (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*))))
(/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
(dolist (class-info-name '#.(let ((result nil))
(maphash (lambda (key value)
(declare (ignore value))
(push key result))
*info-classes*)
- result))
+ (sort result #'string<)))
(let ((class-info (make-class-info class-info-name)))
(setf (gethash class-info-name *info-classes*)
class-info)))
(list (type-info-name info-type)
(class-info-name (type-info-class info-type))
(type-info-number info-type)
- (type-info-type info-type))))
+ ;; KLUDGE: for repeatable xc fasls, to
+ ;; avoid different cross-compiler
+ ;; treatment of equal constants here we
+ ;; COPY-TREE, which is not in general a
+ ;; valid identity transformation
+ ;; [e.g. on (EQL (FOO))] but is OK for
+ ;; all the types we use here.
+ (copy-tree (type-info-type info-type)))))
*info-types*)))
(/show0 "done with *INFO-TYPES* initialization"))
,@(reverse *!reversed-type-info-init-forms*))))
(frob))
\f
+;;; Source transforms / compiler macros for INFO functions.
+;;;
+;;; When building the XC, we give it a source transform, so that it can
+;;; compile INFO calls in the target efficiently; we also give it a compiler
+;;; macro, so that at least those INFO calls compiled after this file can be
+;;; efficient. (Host compiler-macros do not fire when compiling the target,
+;;; and source transforms don't fire when building the XC, so we need both.)
+;;;
+;;; Target needs just one, since there compiler macros and source-transforms
+;;; are equivalent.
+(macrolet ((def (name lambda-list form)
+ (aver (member 'class lambda-list))
+ (aver (member 'type lambda-list))
+ `(progn
+ #+sb-xc-host
+ (define-source-transform ,name ,lambda-list
+ (if (and (keywordp class) (keywordp type))
+ ,form
+ (values nil t)))
+ (define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list)
+ (if (and (keywordp class) (keywordp type))
+ ,form
+ .whole.)))))
+
+ (def info (class type name)
+ (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type)))
+ (with-unique-names (value foundp)
+ `(multiple-value-bind (,value ,foundp)
+ (get-info-value ,name ,(type-info-number info))
+ (declare (type ,(type-info-type info) ,value))
+ (values ,value ,foundp)))))
+
+ (def (setf info) (new-value class type name)
+ (let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type))
+ (tin (type-info-number info))
+ (validate (type-info-validate-function info)))
+ (with-unique-names (new check)
+ `(let ((,new ,new-value)
+ ,@(when validate
+ `((,check (type-info-validate-function (svref *info-types* ,tin))))))
+ ,@(when validate
+ `((funcall ,check ',name ,new)))
+ (set-info-value ,name
+ ,tin
+ ,new)))))
+
+ (def clear-info (class type name)
+ (let ((info (type-info-or-lose class type)))
+ `(clear-info-value ,name ,(type-info-number info)))))
+\f
;;;; a hack for detecting
;;;; (DEFUN FOO (X Y)
;;;; ..
projects / sbcl.git / blobdiff